commit 081686423119daac61023b6d059138a1f4fa0b6f (HEAD, refs/remotes/origin/master) Merge: 21dc6d37783 07505fd6c5e Author: Eshel Yaron Date: Sun Oct 12 17:12:48 2025 +0200 Merge branch 'feature/elisp-fontify-semantically' commit 07505fd6c5e32f52efe2ef3237a0ee8ecdfac39b Author: Eshel Yaron Date: Sun Oct 12 17:09:36 2025 +0200 ; elisp-scope.el: Improve customization group name handling. * lisp/emacs-lisp/elisp-scope.el (elisp-scope-quoted-group): Delete it. (define-minor-mode, define-derived-mode): Simplify analyzers. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 1ccf32324de..5933a92745f 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1239,13 +1239,6 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'deftype beg (length (symbol-name bare)))) (elisp-scope-lambda args body)) -(defun elisp-scope-quoted-group (sym-form) - (when-let* (((eq (elisp-scope-sym-bare (car-safe sym-form)) 'quote)) - (sym (cadr sym-form)) - (beg (elisp-scope-sym-pos sym)) - (bare (elisp-scope-sym-bare sym))) - (elisp-scope-report 'group beg (length (symbol-name bare))))) - (defun elisp-scope-defmethod-1 (local args body) (if args (let ((arg (car args)) (bare nil)) @@ -1566,8 +1559,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-sharpquote tail)) (elisp-scope-1 place))) (setq explicit-var t)) - ((:group) - (elisp-scope-quoted-group (cadr body))) + ((:group) (elisp-scope-1 (cadr body) '(symbol . group))) ((:predicate) ;For globalized minor modes. (elisp-scope-global-minor-mode-predicate (cadr body))) ((:on :off) @@ -2273,7 +2265,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." ((keywordp bkw))) (elisp-scope-report-s kw 'constant) (cl-case bkw - (:group (elisp-scope-quoted-group (cadr body))) + (:group (elisp-scope-1 (cadr body) '(symbol . group))) ((:syntax-table :abbrev-table :after-hook) (elisp-scope-1 (cadr body)))) (setq body (cddr body))) (elisp-scope-n body)) commit 81867057529af488bfc1dde66581f2d546ac42f0 Author: Eshel Yaron Date: Thu Oct 9 10:29:01 2025 +0200 ; elisp-scope.el: Improve widget-type handling. Use argument specs to analyze complex widget types. * lisp/emacs-lisp/elisp-scope.el (elisp-scope-widget-type) (elisp-scope-widget-type-1) (elisp-scope-widget-type-keyword-arguments) (elisp-scope-widget-type-arguments) (elisp-scope-widget-type-arguments-1): Delete, no longer used. (custom-declare-variable, define-widget): Simplify analyzers. (elisp-scope--match-spec-to-arg): Add new 'list', 'and', and 'plist-and-then' parametric specs, and add 'widget-type' as a new recursive spec. * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el Add test. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index d0904199419..1ccf32324de 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1239,65 +1239,6 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'deftype beg (length (symbol-name bare)))) (elisp-scope-lambda args body)) -(defun elisp-scope-widget-type (form) - (when-let* (((memq (elisp-scope-sym-bare (car-safe form)) '(quote \`))) - (type (cadr form))) - (elisp-scope-widget-type-1 type))) - -(defun elisp-scope-widget-type-1 (type) - (cond - ((symbol-with-pos-p type) - (when-let* ((beg (elisp-scope-sym-pos type)) (bare (elisp-scope-sym-bare type))) - (elisp-scope-report 'widget-type - (symbol-with-pos-pos type) - (length (symbol-name (bare-symbol type)))))) - ((consp type) - (let ((head (car type))) - (when-let* ((beg (elisp-scope-sym-pos head)) (bare (elisp-scope-sym-bare head))) - (elisp-scope-report 'widget-type beg (length (symbol-name bare)))) - (when-let* ((bare (elisp-scope-sym-bare head))) - (elisp-scope-widget-type-arguments bare (cdr type))))))) - -(defun elisp-scope-widget-type-keyword-arguments (head kw args) - (when-let* ((beg (elisp-scope-sym-pos kw)) - (len (length (symbol-name (bare-symbol kw))))) - (elisp-scope-report 'constant beg len)) - (cond - ((and (memq head '(plist alist)) - (memq kw '(:key-type :value-type))) - (elisp-scope-widget-type-1 (car args))) - ((memq kw '(:action :match :match-inline :validate)) - (when-let* ((fun (car args)) - (beg (elisp-scope-sym-pos fun)) - (bare (elisp-scope-sym-bare fun))) - (elisp-scope-report 'function beg (length (symbol-name bare))))) - ((memq kw '(:args)) - (mapc #'elisp-scope-widget-type-1 (car args)))) - ;; TODO: (restricted-sexp :match-alternatives CRITERIA) - (elisp-scope-widget-type-arguments head (cdr args))) - -(defun elisp-scope-widget-type-arguments (head args) - (let* ((arg (car args)) - (bare (elisp-scope-sym-bare arg))) - (if (keywordp bare) - (elisp-scope-widget-type-keyword-arguments head bare (cdr args)) - (elisp-scope-widget-type-arguments-1 head args)))) - -(defun elisp-scope-widget-type-arguments-1 (head args) - (cl-case head - ((list cons group vector choice radio set repeat checklist) - (mapc #'elisp-scope-widget-type-1 args)) - ((function-item) - (when-let* ((fun (car args)) - (beg (elisp-scope-sym-pos fun)) - (bare (elisp-scope-sym-bare fun))) - (elisp-scope-report 'function beg (length (symbol-name bare))))) - ((variable-item) - (when-let* ((var (car args)) - (beg (elisp-scope-sym-pos var)) - (bare (elisp-scope-sym-bare var))) - (elisp-scope-report 'free-variable beg (length (symbol-name bare))))))) - (defun elisp-scope-quoted-group (sym-form) (when-let* (((eq (elisp-scope-sym-bare (car-safe sym-form)) 'quote)) (sym (cadr sym-form)) @@ -1928,15 +1869,10 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) (elisp-scope-report-s kw 'constant) - (cl-case bkw - (:type - ;; TODO: Use `elisp-scope-1' with an appropriate outspec. - (if-let* ((quoted (elisp-scope--unquote (cadr args)))) - (elisp-scope-widget-type-1 quoted) - (elisp-scope-1 (cadr args)))) - (:group - (elisp-scope-1 (cadr args) '(symbol . group))) - (otherwise (elisp-scope-1 (cadr args)))) + (elisp-scope-1 (cadr args) + (cl-case bkw + (:type 'widget-type) + (:group '(symbol . group)))) (setq args (cddr args))) (when args (elisp-scope-n args))) @@ -2132,17 +2068,10 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) (elisp-scope-report-s kw 'constant) - (cl-case bkw - (:type - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. - (if-let* ((quoted (elisp-scope--unquote (cadr args)))) - (elisp-scope-widget-type-1 quoted) - (elisp-scope-1 (cadr args)))) - (:args - (if-let* ((quoted (elisp-scope--unquote (cadr args)))) - (mapc #'elisp-scope-widget-type-1 quoted) - (elisp-scope-1 (cadr args)))) - (otherwise (elisp-scope-1 (cadr args)))) + (elisp-scope-1 (cadr args) + (cl-case bkw + (:type 'widget-type) + (:args '(repeat . widget-type)))) (setq args (cddr args))) (when args (elisp-scope-n args))) @@ -2727,10 +2656,13 @@ property, or if the current buffer is trusted (see `trusted-content-p')." '(or (symbol) (cons (member symbol) . (symbol . symbol-role)) (cons (member repeat) . spec) + (cons (member list) . spec) (cons (member or) . (repeat . spec)) + (cons (member and) . (repeat . spec)) (cons (member cons) . (cons spec . spec)) (cons (member member) . t) - (cons (member plist) . (repeat . (cons (symbol . constant) . spec)))) + (cons (member plist) . (repeat . (cons (symbol . constant) . spec))) + (cons (member plist-and-then) . (repeat . (cons (symbol . constant) . spec)))) arg)) (cl-defmethod elisp-scope--match-spec-to-arg ((_spec (eql 'cl-type)) arg) @@ -2744,6 +2676,30 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cons (member satisfies) . (cons (or (symbol . function) code) . t))) arg)) +(cl-defmethod elisp-scope--match-spec-to-arg ((_spec (eql 'widget-type)) arg) + (elisp-scope--match-spec-to-arg + (let ((kws + '((:key-type . widget-type) + (:value-type . widget-type) + (:action . (symbol . function)) + (:match . (symbol . function)) + (:match-inline . (symbol . function)) + (:validate . (symbol . function)) + (:args . (repeat . widget-type))))) + `(or (symbol . widget-type) + (cons (and (member cons group vector choice radio set repeat checklist) + (symbol . widget-type)) + . (plist-and-then ,@kws (t . (repeat . widget-type)))) + (cons (and (member function-item) + (symbol . widget-type)) + . (plist-and-then ,@kws (t . (list (symbol . function))))) + (cons (and (member variable-item) + (symbol . widget-type)) + . (plist-and-then ,@kws (t . (list (symbol . free-variable))))) + (cons (symbol . widget-type) ;Fallback. + . (plist-and-then ,@kws (t . (repeat . t)))))) + arg)) + (cl-defmethod elisp-scope--match-spec-to-arg ((spec (head symbol)) arg) (when (or (symbolp arg) (symbol-with-pos-p arg)) spec)) @@ -2761,6 +2717,15 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (if-let* ((res (elisp-scope--match-spec-to-arg (car specs) arg))) res (loop (cdr specs)))))) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head and)) arg) + (let ((specs (cdr spec))) + (if (null specs) t + (let ((go t)) + (while (and (cdr specs) (setq go (elisp-scope--match-spec-to-arg + (car specs) arg))) + (pop specs)) + (when go (elisp-scope--match-spec-to-arg (car specs) arg)))))) + (cl-defmethod elisp-scope--match-spec-to-arg ((spec (head cons)) arg) (when (consp arg) (let ((car-spec (cadr spec)) @@ -2786,6 +2751,35 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (when go (cons 'list (nreverse res))))) ((null arg) t))) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head list)) arg) + (cond + ((consp arg) + (let ((specs (cdr spec)) (go t) res) + (while (and specs (setq go (elisp-scope--match-spec-to-arg (pop specs) (pop arg)))) + (push go res)) + (when go (cons 'list (nreverse res))))) + ((null arg) t))) + +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head plist-and-then)) arg) + (cond + ((consp arg) + (let ((val-spec-alist (cdr spec)) + (res nil) + (go t) + bkw) + (while (and go (keywordp (setq bkw (elisp-scope-sym-bare (car arg))))) + (push '(symbol . constant) res) + (setq go (elisp-scope--match-spec-to-arg (alist-get bkw val-spec-alist t) (cadr arg))) + (push go res) + (setq arg (cddr arg))) + (when go + (let ((rest-res (elisp-scope--match-spec-to-arg (alist-get t val-spec-alist t) arg))) + (when (eq (car rest-res) 'list) + (setq rest-res (cdr rest-res)) + (dolist (s res) (push s rest-res)) + (cons 'list rest-res)))))) + ((null arg) t))) + (elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) (elisp-scope-1 tag '(symbol . throw-tag)) (elisp-scope-n body elisp-scope-output-spec)) @@ -2839,6 +2833,9 @@ OUTSPEC can be one the following: - (cons CARSPEC . CDRSPEC): FORM evaluates to a cons cell whose `car' has spec CARSPEC and whose `cdr' has spec CDRSPEC. +- (list . SPECS): FORM evaluates to a list of the same length as SPECS, + in which the `i'th element matches the `i'th spec in SPECS. + - (member . VALS): FORM evaluates to a `member' of VALS. - (plist . VALSPECS): FORM evaluates to a plist. VALSPECS is an alist @@ -2848,6 +2845,9 @@ OUTSPEC can be one the following: - (or . SPECS): FORM evaluates to a value that matches one of SPECS. +- (and . SPECS): FORM evaluates to a value that matches all of SPECS. + The last spec in SPECS determines how to analyze FORM if it matches. + For example, to analyze a FORM that evaluates to either a list of major mode names or just to a single major mode name, use OUTSPEC as follows: diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index 25949c61818..24c5a17b8aa 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -123,3 +123,29 @@ ;; ^ elisp-bound-variable foo) ;; ^ elisp-bound-variable + +;; Taken from minibuffer.el: +(defcustom my-foo nil +;; ^ (elisp-macro font-lock-keyword-face) +;; ^ (elisp-defvar font-lock-variable-name-face) + "Foo." + :type '(choice (const :tag "No special message handling" nil) +;; ^ elisp-widget-type +;; ^ elisp-widget-type + (repeat +;; ^ elisp-widget-type + (choice (function-item :tag "Inhibit some messages" +;; ^ elisp-widget-type +;; ^ elisp-widget-type + inhibit-message) +;; ^ elisp-function + (function-item :tag "Accumulate messages" + set-multi-message) +;; ^ elisp-function + (function-item :tag "Handle minibuffer" + set-minibuffer-message) +;; ^ elisp-function + (function :tag "Custom function") +;; ^ (elisp-widget-type font-lock-keyword-face) + ))) + :version "29.1") commit 21dc6d377838e1902b746d57bfaf86cc4e3d3b65 Author: Eli Zaretskii Date: Sun Oct 12 17:30:05 2025 +0300 Fix squashfs archives embedded in another archive * lisp/arc-mode.el (archive-delete-local): Delete the directory recursively. (archive-squashfs-summarize): Make a local copy of a file if squashfs archive is included in another archive. (Bug#79582) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 66cb89c3342..2de1277f932 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1012,7 +1012,7 @@ using `make-temp-file', and the generated name is returned." (while again (setq name (directory-file-name (file-name-directory name))) (condition-case nil - (delete-directory name) + (delete-directory name t) (error nil)) (if (string= name top) (setq again nil))))) ;; ------------------------------------------------------------------------- @@ -2453,7 +2453,21 @@ NAME is expected to be the 16-bytes part of an ar record." (unless file (setq file buffer-file-name)) (let ((copy (file-local-copy file)) - (files ())) + (files ()) + to-delete) + ;; Similar to 'archive-maybe-copy'. + (unless (or (and copy (null file)) + (file-readable-p file)) + (setq archive-local-name + (archive-unique-fname (or file copy (buffer-name)) + archive-tmpdir) + file archive-local-name + to-delete t) + (save-restriction + (widen) + (let ((coding-system-for-write 'no-conversion)) + (write-region (point-min) (point-max) + archive-local-name nil 'nomessage)))) (with-temp-buffer (call-process "unsquashfs" nil t nil "-ll" (or file copy)) (when copy @@ -2500,6 +2514,8 @@ NAME is expected to be the 16-bytes part of an ar record." date-time :uid uid :gid gid) files))) (goto-char (match-end 0)))) + (if to-delete + (archive-delete-local archive-local-name)) (archive--summarize-descs (nreverse files)))) (defun archive-squashfs-extract-by-stdout (archive name command commit b1f924e12f2c1a8e3bad7872b96a9d5caa21c844 Author: Stefan Monnier Date: Sun Oct 12 09:50:31 2025 -0400 (read-only-keymap-*): Be more careful with the namespace * lisp/keymap.el (keymap-read-only-bind): Rename from `read-only-keymap-bind`. Improve docstring. (keymap--read-only-filter): Rename from `read-only-keymap-filter`. * lisp/net/goto-addr.el (goto-address-highlight-keymap): * lisp/progmodes/bug-reference.el (bug-reference-map): * lisp/net/browse-url.el (browse-url-button-map): * lisp/ansi-osc.el (ansi-osc-hyperlink-map): Adjust accordingly. diff --git a/lisp/ansi-osc.el b/lisp/ansi-osc.el index 1facd9aa205..77b1f7b393d 100644 --- a/lisp/ansi-osc.el +++ b/lisp/ansi-osc.el @@ -146,7 +146,7 @@ and `shell-dirtrack-mode'." (defvar-keymap ansi-osc-hyperlink-map :doc "Keymap used by OSC 8 hyperlink buttons." - "RET" (read-only-keymap-bind #'browse-url-button-open) + "RET" (keymap-read-only-bind #'browse-url-button-open) "C-c RET" #'browse-url-button-open "" #'browse-url-button-open "" 'mouse-face) diff --git a/lisp/keymap.el b/lisp/keymap.el index 98b4a026fd3..b418d157619 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -801,16 +801,19 @@ in the echo area. -(defun read-only-keymap-filter (cmd) +(defun keymap--read-only-filter (cmd) "Return CMD if `browse-url' and similar button bindings should be active. They are considered active only in read-only buffers." (when buffer-read-only cmd)) -(defun read-only-keymap-bind (binding) - "Use BINDING according to `read-only-keymap-filter'." +(defun keymap-read-only-bind (binding) + "Behave like BINDING, but only when the buffer is read-only. +BINDING should be a command to pput in a keymap. +Return an element that can be added in a keymap with `keymap-set', such that +it is active only when the current buffer is read-only." `(menu-item "" ,binding - :filter ,#'read-only-keymap-filter)) + :filter ,#'keymap--read-only-filter)) (provide 'keymap) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index cd0a88b1a16..2b8964d1ece 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1761,7 +1761,7 @@ from `browse-url-elinks-wrapper'." (defvar-keymap browse-url-button-map :doc "The keymap used for `browse-url' buttons." - "RET" (read-only-keymap-bind #'browse-url-button-open) + "RET" (keymap-read-only-bind #'browse-url-button-open) "C-c RET" #'browse-url-button-open "" #'browse-url-button-open "w" #'browse-url-button-copy) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index c1f8b72f137..fa346a5d944 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -121,7 +121,7 @@ will have no effect.") (defvar-keymap goto-address-highlight-keymap :doc "Keymap to hold goto-addr's mouse key defs under highlighted URLs." "" #'goto-address-at-point - "RET" (read-only-keymap-bind #'goto-address-at-point) + "RET" (keymap-read-only-bind #'goto-address-at-point) "C-c RET" #'goto-address-at-point) (defun goto-address-context-menu (menu click) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 0b5c36d0ed2..b6ce135be3e 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -45,7 +45,7 @@ (defvar-keymap bug-reference-map :doc "Keymap used by bug reference buttons." "" #'bug-reference-push-button - "RET" (read-only-keymap-bind #'bug-reference-push-button) + "RET" (keymap-read-only-bind #'bug-reference-push-button) "C-c RET" #'bug-reference-push-button) ;; E.g., "https://gcc.gnu.org/PR%s" commit 06639a6b9b8e60f1b5b4a69b137e503b56fb7453 Author: Michael Albinus Date: Sun Oct 12 14:34:53 2025 +0200 Fix regression in Tramp file name completion * lisp/net/tramp.el (tramp-make-tramp-file-name): Do not use the hop for the "archive" method. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3834c950c93..546ffa5d638 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1939,6 +1939,9 @@ expected to be a string, which will be used." (when (cadr args) (setq localname (and (stringp (cadr args)) (cadr args)))) (when hop + ;; Do not keep the hop for the "archive" method. + (when (string-equal method tramp-archive-method) + (setq hop nil)) ;; Keep hop in file name for completion or when indicated. (unless (or minibuffer-completing-file-name tramp-show-ad-hoc-proxies) (setq hop nil)) commit d1e173140de4036db2223a68c24942d36aa3e2c0 Author: James Thomas Date: Sun Oct 12 14:06:29 2025 +0530 ; * doc/misc/gnus.texi (Optional Back End Functions): Add newer (bug#79484). diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 777ab5f7dac..74da7df3247 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -30269,6 +30269,19 @@ in the same format as @code{nnchoke-request-group} gives. group-buffer = *active-line / *group-status @end example +@item (nnchoke-retrieve-group-data-early @var{server} &optional @var{infos}) + +This is for starting an early async retrieval from @var{server} to +update @var{infos}, its current group info structure list. The return +value is a token for the corresponding +@code{nnchoke-finish-retrieve-group-infos}. + +@item (nnchoke-finish-retrieve-group-infos @var{server} @var{infos} @var{data}) + +This will be called later to conclude the async retrieval of +@code{nnchoke-retrieve-group-data-early} -- whose token is passed as +@var{data} -- and should update @var{infos}. + @item (nnchoke-request-update-info @var{group} @var{info} &optional @var{server}) A Gnus group info (@pxref{Group Info}) is handed to the back end for commit 1ec7f8f9b20dc88caa06859a3a7d50143a9590f3 Author: James Thomas Date: Sun Oct 12 14:00:29 2025 +0530 ; * doc/misc/gnus.texi: Fix formatting (bug#79484). diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index e0a9c54c328..777ab5f7dac 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -30023,7 +30023,7 @@ In the examples and definitions I will refer to the imaginary back end @table @code -@item (nnchoke-retrieve-headers ARTICLES &optional GROUP SERVER FETCH-OLD) +@item (nnchoke-retrieve-headers @var{articles} &optional @var{group} @var{server} @var{fetch-old}) @var{articles} is either a range of article numbers or a list of @code{Message-ID}s. Current back ends do not fully support either---only @@ -30092,7 +30092,7 @@ For a closer look at what should be in those fields, @pxref{Headers}. -@item (nnchoke-open-server SERVER &optional DEFINITIONS) +@item (nnchoke-open-server @var{server} &optional @var{definitions}) @var{server} is here the virtual server name. @var{definitions} is a list of @code{(VARIABLE VALUE)} pairs that define this virtual server. @@ -30105,7 +30105,7 @@ If the server is opened already, this function should return a non-@code{nil} value. There should be no data returned. -@item (nnchoke-close-server &optional SERVER) +@item (nnchoke-close-server &optional @var{server}) Close connection to @var{server} and free all resources connected to it. Return @code{nil} if the server couldn't be closed for some @@ -30124,7 +30124,7 @@ function is generally only called when Gnus is shutting down. There should be no data returned. -@item (nnchoke-server-opened &optional SERVER) +@item (nnchoke-server-opened &optional @var{server}) If @var{server} is the current virtual server, and the connection to the physical server is alive, then this function should return a @@ -30134,14 +30134,14 @@ attempt to reconnect to a server we have lost connection to. There should be no data returned. -@item (nnchoke-status-message &optional SERVER) +@item (nnchoke-status-message &optional @var{server}) This function should return the last error message from @var{server}. There should be no data returned. -@item (nnchoke-request-article ARTICLE &optional GROUP SERVER TO-BUFFER) +@item (nnchoke-request-article @var{article} &optional @var{group} @var{server} @var{to-buffer}) The result data from this function should be the article specified by @var{article}. This might either be a @code{Message-ID} or a number. @@ -30162,7 +30162,7 @@ group and article numbers are when fetching articles by on successful article retrieval. -@item (nnchoke-request-group GROUP &optional SERVER FAST INFO) +@item (nnchoke-request-group @var{group} &optional @var{server} @var{fast} @var{info}) Get data on @var{group}. This function also has the side effect of making @var{group} the current group. @@ -30197,7 +30197,7 @@ info = "211 " 3* [ " " ] @end example -@item (nnchoke-close-group GROUP &optional SERVER) +@item (nnchoke-close-group @var{group} &optional @var{server}) Close @var{group} and free any resources connected to it. This will be a no-op on most back ends. @@ -30205,7 +30205,7 @@ a no-op on most back ends. There should be no data returned. -@item (nnchoke-request-list &optional SERVER) +@item (nnchoke-request-list &optional @var{server}) Return a list of all groups available on @var{server}. And that means @emph{all}. @@ -30234,7 +30234,7 @@ The flag says whether the group is read-only (@samp{n}), is moderated (@samp{=other-group}) or none of the above (@samp{y}). -@item (nnchoke-request-post &optional SERVER) +@item (nnchoke-request-post &optional @var{server}) This function should post the current buffer. It might return whether the posting was successful or not, but that's not required. If, for @@ -30253,7 +30253,7 @@ There should be no result data from this function. @table @code -@item (nnchoke-retrieve-groups GROUPS &optional SERVER) +@item (nnchoke-retrieve-groups @var{groups} &optional @var{server}) @var{groups} is a list of groups, and this function should request data on all those groups. How it does it is of no concern to Gnus, but it @@ -30269,8 +30269,7 @@ in the same format as @code{nnchoke-request-group} gives. group-buffer = *active-line / *group-status @end example - -@item (nnchoke-request-update-info GROUP INFO &optional SERVER) +@item (nnchoke-request-update-info @var{group} @var{info} &optional @var{server}) A Gnus group info (@pxref{Group Info}) is handed to the back end for alterations. This comes in handy if the back end really carries all @@ -30283,7 +30282,7 @@ the network resources). There should be no result data from this function. -@item (nnchoke-request-type GROUP &optional ARTICLE) +@item (nnchoke-request-type @var{group} &optional @var{article}) When the user issues commands for ``sending news'' (@kbd{F} in the summary buffer, for instance), Gnus has to know whether the article the @@ -30297,7 +30296,7 @@ and @var{article} may be @code{nil}. There should be no result data from this function. -@item (nnchoke-request-set-mark GROUP ACTION &optional SERVER) +@item (nnchoke-request-set-mark @var{group} @var{action} &optional @var{server}) Set/remove/add marks on articles. Normally Gnus handles the article marks (such as read, ticked, expired etc.)@: internally, and store them in @@ -30308,7 +30307,7 @@ propagate the mark information to the server. @var{action} is a list of mark setting requests, having this format: @example -(RANGE ACTION MARK) +(@code{range} @code{action} @code{mark}) @end example @var{range} is a range of articles you wish to update marks on. @@ -30338,7 +30337,7 @@ mark on (currently not used for anything). There should be no result data from this function. -@item (nnchoke-request-update-mark GROUP ARTICLE MARK) +@item (nnchoke-request-update-mark @var{group} @var{article} @var{mark}) If the user tries to set a mark that the back end doesn't like, this function may change the mark. Gnus will use whatever this function @@ -30354,7 +30353,7 @@ expirable. There should be no result data from this function. -@item (nnchoke-request-scan &optional GROUP SERVER) +@item (nnchoke-request-scan &optional @var{group} @var{server}) This function may be called at any time (by Gnus or anything else) to request that the back end check for incoming articles, in one way or @@ -30368,7 +30367,7 @@ local if that's practical. There should be no result data from this function. -@item (nnchoke-request-group-description GROUP &optional SERVER) +@item (nnchoke-request-group-description @var{group} &optional @var{server}) The result data from this function should be a description of @var{group}. @@ -30379,7 +30378,7 @@ name = description = @end example -@item (nnchoke-request-list-newsgroups &optional SERVER) +@item (nnchoke-request-list-newsgroups &optional @var{server}) The result data from this function should be the description of all groups available on the server. @@ -30389,7 +30388,7 @@ description-buffer = *description-line @end example -@item (nnchoke-request-newgroups DATE &optional SERVER) +@item (nnchoke-request-newgroups @var{date} &optional @var{server}) The result data from this function should be all groups that were created after @samp{date}, which is in normal human-readable date format @@ -30406,14 +30405,14 @@ back ends like @code{nntp}, where the groups have been created by the server, it is quite likely that there can be many groups. -@item (nnchoke-request-create-group GROUP &optional SERVER) +@item (nnchoke-request-create-group @var{group} &optional @var{server}) This function should create an empty group with name @var{group}. There should be no return data. -@item (nnchoke-request-expire-articles ARTICLES &optional GROUP SERVER FORCE) +@item (nnchoke-request-expire-articles @var{articles} &optional @var{group} @var{server} @var{force}) This function should run the expiry process on all articles in the @var{articles} range (which is currently a simple list of article @@ -30428,7 +30427,7 @@ able to delete. There should be no result data returned. -@item (nnchoke-request-move-article ARTICLE GROUP SERVER ACCEPT-FORM &optional LAST) +@item (nnchoke-request-move-article @var{article} @var{group} @var{server} @var{accept-form} &optional @var{last}) This function should move @var{article} (which is a number) from @var{group} by calling @var{accept-form}. @@ -30450,7 +30449,7 @@ the @code{cdr} is the article number that the article was entered as. There should be no data returned. -@item (nnchoke-request-accept-article GROUP &optional SERVER LAST) +@item (nnchoke-request-accept-article @var{group} &optional @var{server} @var{last}) This function takes the current buffer and inserts it into @var{group}. If @var{last} in @code{nil}, that means that there will be more calls to @@ -30465,7 +30464,7 @@ article for that group. There should be no data returned. -@item (nnchoke-request-replace-article ARTICLE GROUP BUFFER) +@item (nnchoke-request-replace-article @var{article} @var{group} @var{buffer}) This function should remove @var{article} (which is a number) from @var{group} and insert @var{buffer} there instead. @@ -30473,7 +30472,7 @@ This function should remove @var{article} (which is a number) from There should be no data returned. -@item (nnchoke-request-delete-group GROUP FORCE &optional SERVER) +@item (nnchoke-request-delete-group @var{group} @var{force} &optional @var{server}) This function should delete @var{group}. If @var{force}, it should really delete all the articles in the group, and then delete the group @@ -30482,7 +30481,7 @@ itself. (If there is such a thing as ``the group itself''.) There should be no data returned. -@item (nnchoke-request-rename-group GROUP NEW-NAME &optional SERVER) +@item (nnchoke-request-rename-group @var{group} @var{new-name} &optional @var{server}) This function should rename @var{group} into @var{new-name}. All articles in @var{group} should move to @var{new-name}. commit 73feb431b3a82651d60bde1984a2de56519b2885 Author: Eshel Yaron Date: Sun Oct 12 10:33:58 2025 +0200 ; elisp-mode.el: Improve consistency among face names. Rename a couple of faces to solidify the convention that the face name 'elisp-foo' implies "references to foo", not "foo definitions". For definitions we use 'elisp-deffoo' if foo is only one word, or 'elisp-bar-baz-definition' otherwise. * lisp/progmodes/elisp-mode.el (elisp-function-reference): Rename to 'elisp-function'. (elisp-macro-call): Rename to 'elisp-macro'. (elisp-non-local-exit): (elisp-unknown-call): (elisp-special-form): * lisp/emacs-lisp/elisp-scope.el: * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el: Update references to renamed faces. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 36acf7cbd0c..d0904199419 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -292,7 +292,7 @@ symbol role properties." (elisp-scope-define-symbol-role function (callable) :doc "Function names." - :face 'elisp-function-reference + :face 'elisp-function :help (lambda (beg end def) (cond ((equal beg def) "Local function definition") (def "Local function call") @@ -318,7 +318,7 @@ symbol role properties." (elisp-scope-define-symbol-role macro (callable) :doc "Macro names." - :face 'elisp-macro-call + :face 'elisp-macro :help (lambda (beg end _def) (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) (apply-partially #'elisp--function-help-echo sym) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 2b452bd2a0f..979baa8c1fe 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -328,19 +328,19 @@ code analysis." (defface elisp-symbol-role-definition '((t :foreground "#00008b" :inherit font-lock-function-name-face)) "Face for highlighting symbol role definitions in Emacs Lisp code.") -(defface elisp-function-reference '((t :inherit font-lock-function-call-face)) +(defface elisp-function '((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")) +(defface elisp-non-local-exit '((t :inherit elisp-function :underline "red")) "Face for highlighting calls to functions that do not return.") -(defface elisp-unknown-call '((t :inherit elisp-function-reference :foreground "#2f4f4f")) +(defface elisp-unknown-call '((t :inherit elisp-function :foreground "#2f4f4f")) "Face for highlighting unknown functions/macros in Emacs Lisp code.") -(defface elisp-macro-call '((t :inherit font-lock-keyword-face)) +(defface elisp-macro '((t :inherit font-lock-keyword-face)) "Face for highlighting macro calls in Emacs Lisp code.") -(defface elisp-special-form '((t :inherit elisp-macro-call)) +(defface elisp-special-form '((t :inherit elisp-macro)) "Face for highlighting special forms in Emacs Lisp code.") (defface elisp-throw-tag '((t :inherit font-lock-constant-face)) diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index a41fb05ce18..25949c61818 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -1,7 +1,7 @@ ;;; semantic-highlighting.el --- -*- lexical-binding: t; -*- (defun foo (bar) -;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-macro font-lock-keyword-face) ;; ^ (elisp-defun font-lock-function-name-face) ;; ^ elisp-binding-variable (let ((cpa current-prefix-arg)) @@ -11,42 +11,42 @@ (or cpa (ignore bar))) ;; ^ (elisp-special-form font-lock-keyword-face) ;; ^ elisp-bound-variable -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable ) (add-face-text-property -;; ^ elisp-function-reference +;; ^ elisp-function (point) (mark) -;; ^ elisp-function-reference -;; ^ elisp-function-reference +;; ^ elisp-function +;; ^ elisp-function (if not-good ;; ^ (elisp-special-form font-lock-keyword-face) ;; ^ elisp-free-variable 'error ;; ^ elisp-face (message "Good.") -;; ^ elisp-function-reference +;; ^ elisp-function 'success)) ;; ^ elisp-face (require 'cl-lib) -;; ^ (elisp-function-reference font-lock-keyword-face) +;; ^ (elisp-function font-lock-keyword-face) ;; ^ (elisp-feature font-lock-constant-face) ;; Taken from `completion-shorthand-try-completion' in minibuffer.el: (defun foobaz (string table pred point) -;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-macro font-lock-keyword-face) ;; ^ (elisp-defun font-lock-function-name-face) ;; ^ ^ ^ ^ elisp-binding-variable (cl-loop with expanded -;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-macro font-lock-keyword-face) ;; ^ elisp-binding-variable for (short . long) in ;; ^ elisp-binding-variable ;; ^ elisp-binding-variable (with-current-buffer minibuffer--original-buffer -;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-macro font-lock-keyword-face) ;; ^ elisp-free-variable read-symbol-shorthands) ;; ^ elisp-free-variable @@ -54,27 +54,27 @@ ;; ^ elisp-binding-variable (and (> point (length short)) ;; ^ (elisp-special-form font-lock-keyword-face) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable (string-prefix-p short string) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable ;; ^ elisp-bound-variable (try-completion (setq expanded -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ (elisp-special-form font-lock-keyword-face) ;; ^ elisp-bound-variable (concat long -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable (substring -;; ^ elisp-function-reference +;; ^ elisp-function string ;; ^ elisp-bound-variable (length short)))) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable table pred)) ;; ^ elisp-bound-variable @@ -82,44 +82,44 @@ when probe ;; ^ elisp-bound-variable do (message "Shorthand expansion") -;; ^ elisp-function-reference +;; ^ elisp-function and return (cons expanded (max (length long) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable -;; ^ elisp-function-reference -;; ^ elisp-function-reference +;; ^ elisp-function +;; ^ elisp-function ;; ^ elisp-bound-variable (+ (- point (length short)) -;; ^ elisp-function-reference -;; ^ elisp-function-reference -;; ^ elisp-function-reference +;; ^ elisp-function +;; ^ elisp-function +;; ^ elisp-function ;; ^ elisp-bound-variable (length long)))))) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable (let ((foo 'bar)) ;; ^ (elisp-special-form font-lock-keyword-face) ;; ^ elisp-binding-variable (cl-flet ((foo () 'baz)) -;; ^ (elisp-macro-call font-lock-keyword-face) -;; ^ elisp-function-reference +;; ^ (elisp-macro font-lock-keyword-face) +;; ^ elisp-function (foo) -;; ^ elisp-function-reference +;; ^ elisp-function (cl-macrolet ((foo () 'foo)) -;; ^ (elisp-macro-call font-lock-keyword-face) -;; ^ elisp-macro-call +;; ^ (elisp-macro font-lock-keyword-face) +;; ^ elisp-macro (foo)))) -;; ^ elisp-macro-call +;; ^ elisp-macro (when-let* ((foo (symbol-at-point)) -;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-macro font-lock-keyword-face) ;; ^ elisp-binding-variable -;; ^ elisp-function-reference +;; ^ elisp-function current-prefix-arg ;; ^ elisp-shadowing-variable ((commandp foo))) -;; ^ elisp-function-reference +;; ^ elisp-function ;; ^ elisp-bound-variable foo) ;; ^ elisp-bound-variable commit 026f3bbd8d394ecf3fead9ee2d45dc54ce40b60a Author: Eshel Yaron Date: Sun Oct 12 10:14:29 2025 +0200 ; elisp-scope.el: Clean up symbol role definitions. * lisp/progmodes/elisp-mode.el (elisp-fontify-semantically): Fix typo in doc string. (elisp--annotate-symbol-with-help-echo): Accept plain string as value of ':help' symbol role property. * lisp/emacs-lisp/elisp-scope.el: Remove unused symbol role properties from all defined symbol roles. Use plain strings for ':help' instead of wrapping them with 'cl-constantly'. Cease 'require'ing 'cl-lib', no longer needed in runtime. (elisp-scope-define-symbol-role): Update doc string. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 340b9f55558..36acf7cbd0c 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -131,8 +131,6 @@ ;;; Code: -(require 'cl-lib) - (defun elisp-scope--define-symbol-role (name parents props) (put name 'elisp-scope-parent-roles parents) (put name 'elisp-scope-role-properties props)) @@ -145,7 +143,17 @@ of (other) symbols in ELisp source code. For example, the symbol role `face' characterizes symbols that are face names. PROPS is a plist specifying the properties of the new symbol role NAME. -NAME inherits properties that do not appear in PROPS from its PARENTS." +NAME inherits properties that do not appear in PROPS from its PARENTS. + +Common symbol role properties are: + +- `:doc': short documentation string describing this symbol role. +- `:face': face for highlighting symbols with this role. +- `:help': `help-echo' text for symbols with this role. + +See also `elisp-scope-get-symbol-role-property' and +`elisp-scope-set-symbol-role-property' for getting and setting values of +symbol role properties." (declare (indent defun)) `(elisp-scope--define-symbol-role ',name ',parents ,(when props `(list ,@props)))) @@ -230,25 +238,19 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role symbol-role () :doc "Symbol role names." - :definition 'symbol-role-definition :face 'elisp-symbol-role - :help (cl-constantly "Symbol role") - :namespace 'symbol-role) + :help "Symbol role") (elisp-scope-define-symbol-role symbol-role-definition (symbol-role) :doc "Symbol role name definitions." :face 'elisp-symbol-role-definition - :help (cl-constantly "Symbol role definition") - :imenu "Symbol Role" - :namespace 'symbol-role) + :help "Symbol role definition") (elisp-scope-define-symbol-role variable () - :doc "Abstract symbol role of variables." - :namespace 'variable) + :doc "Abstract symbol role of variables.") (elisp-scope-define-symbol-role free-variable (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)))) @@ -262,38 +264,34 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role bound-variable (variable) :doc "Local variable names." :face 'elisp-bound-variable - :help (cl-constantly "Local variable")) + :help "Local variable") (elisp-scope-define-symbol-role binding-variable (bound-variable) :doc "Local variable definitions." :face 'elisp-binding-variable - :help (cl-constantly "Local variable binding")) + :help "Local variable binding") (elisp-scope-define-symbol-role shadowed-variable (variable) :doc "Locally shadowed variable names." :face 'elisp-shadowed-variable - :help (cl-constantly "Locally shadowed variable")) + :help "Locally shadowed variable") (elisp-scope-define-symbol-role shadowing-variable (shadowed-variable) - :doc "Local variable definitions." + :doc "Locally shadowing variables." :face 'elisp-shadowing-variable - :help (cl-constantly "Local variable shadowing")) + :help "Local variable shadowing") (elisp-scope-define-symbol-role face () :doc "Face names." - :definition 'defface :face 'elisp-face :help (lambda (beg end _def) - (elisp--help-echo beg end 'face-documentation "Face")) - :namespace 'face) + (elisp--help-echo beg end 'face-documentation "Face"))) (elisp-scope-define-symbol-role callable () - :doc "Abstract symbol role of function-like symbols." - :namespace 'function) + :doc "Abstract symbol role of function-like symbols.") (elisp-scope-define-symbol-role function (callable) :doc "Function names." - :definition '(defun defcmd) :face 'elisp-function-reference :help (lambda (beg end def) (cond ((equal beg def) "Local function definition") @@ -308,7 +306,7 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role unknown (function) :doc "Unknown symbols at function position." :face 'elisp-unknown-call - :help (cl-constantly "Unknown callable")) + :help "Unknown callable") (elisp-scope-define-symbol-role non-local-exit (function) :doc "Functions that do not return." @@ -320,7 +318,6 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role 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)))) @@ -338,97 +335,85 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role throw-tag () :doc "Symbols used as `throw'/`catch' tags." :face 'elisp-throw-tag - :help (cl-constantly "`throw'/`catch' tag")) + :help "`throw'/`catch' tag") (elisp-scope-define-symbol-role warning-type () :doc "Byte-compilation warning types." :face 'elisp-warning-type - :help (cl-constantly "Warning type")) + :help "Warning type") (elisp-scope-define-symbol-role feature () :doc "Feature names." - :definition 'deffeature :face 'elisp-feature - :help (cl-constantly "Feature") - :namespace 'feature) + :help "Feature") (elisp-scope-define-symbol-role deffeature (feature) :doc "Feature definitions." - :imenu "Feature" - :help (cl-constantly "Feature definition")) + :help "Feature definition") (elisp-scope-define-symbol-role function-property-declaration () :doc "Function/macro property declaration types." :face 'elisp-function-property-declaration - :help (cl-constantly "Function/macro property declaration")) + :help "Function/macro property declaration") (elisp-scope-define-symbol-role rx-construct () :doc "`rx' constructs." :face 'elisp-rx - :help (cl-constantly "`rx' construct")) + :help "`rx' construct") (elisp-scope-define-symbol-role theme () :doc "Custom theme names." - :definition 'deftheme :face 'elisp-theme - :help (cl-constantly "Theme")) + :help "Theme") (elisp-scope-define-symbol-role deftheme (theme) :doc "Custom theme definitions." - :imenu "Theme" - :help (cl-constantly "Theme definition")) + :help "Theme definition") (elisp-scope-define-symbol-role thing () :doc "`thing-at-point' \"thing\" identifiers." :face 'elisp-thing - :help (cl-constantly "Thing (text object)")) + :help "Thing (text object)") (elisp-scope-define-symbol-role slot () :doc "EIEIO slots." :face 'elisp-slot - :help (cl-constantly "Slot")) + :help "Slot") (elisp-scope-define-symbol-role widget-type () :doc "Widget types." - :definition 'widget-type-definition :face 'elisp-widget-type - :help (cl-constantly "Widget type") - :namespace 'widget-type) + :help "Widget type") (elisp-scope-define-symbol-role widget-type-definition (widget-type) :doc "Widget type definitions." - :imenu "Widget" - :help (cl-constantly "Widget type definition")) + :help "Widget type definition") (elisp-scope-define-symbol-role type () :doc "ELisp object type names." :face 'elisp-type - :help (cl-constantly "Type")) + :help "Type") (elisp-scope-define-symbol-role deftype (type) :doc "ELisp object type definitions." - :imenu "Type" - :help (cl-constantly "Type definition")) + :help "Type definition") (elisp-scope-define-symbol-role group () :doc "Customization groups." - :definition 'defgroup :face 'elisp-group - :help (cl-constantly "Customization group")) + :help "Customization group") (elisp-scope-define-symbol-role defgroup (group) :doc "Customization group definitions." - :imenu "Group" - :help (cl-constantly "Customization group definition")) + :help "Customization group definition") (elisp-scope-define-symbol-role nnoo-backend () :doc "`nnoo' backend names." :face 'elisp-nnoo-backend - :help (cl-constantly "`nnoo' backend")) + :help "`nnoo' backend") (elisp-scope-define-symbol-role 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)))) @@ -438,72 +423,53 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." "`condition-case' condition" (when (and msg (not (string-empty-p msg))) `(": " ,msg))))) - "`condition-case' condition")) - :namespace 'condition) + "`condition-case' condition"))) (elisp-scope-define-symbol-role defcondition (condition) :doc "`condition-case' condition definitions." - :definition 'defcondition - :help (cl-constantly "`condition-case' condition definition")) + :help "`condition-case' condition definition") (elisp-scope-define-symbol-role ampersand () :doc "Argument list markers, such as `&optional' and `&rest'." :face 'elisp-ampersand - :help (cl-constantly "Arguments separator")) + :help "Arguments separator") (elisp-scope-define-symbol-role constant () :doc "Self-evaluating symbols." :face 'elisp-constant - :help (cl-constantly "Constant")) + :help "Constant") (elisp-scope-define-symbol-role defun () :doc "Function definitions." - :definition 'defun :face 'elisp-defun - :help (cl-constantly "Function definition") - :imenu "Function" - :namespace 'function) + :help "Function definition") (elisp-scope-define-symbol-role defmacro () :doc "Macro definitions." - :definition 'defmacro :face 'elisp-defmacro - :help (cl-constantly "Macro definition") - :imenu "Macro" - :namespace 'function) + :help "Macro definition") (elisp-scope-define-symbol-role defcmd (defun) :doc "Command definitions." - :definition 'defcmd - :help (cl-constantly "Command definition") - :imenu "Command") + :help "Command definition") (elisp-scope-define-symbol-role defvar () :doc "Variable definitions." - :definition 'defvar :face 'elisp-defvar - :help (cl-constantly "Special variable definition") - :imenu "Variable" - :namespace 'variable) + :help "Special variable definition") (elisp-scope-define-symbol-role special-variable-declaration () :doc "Special variable declarations." - :definition 'defvar :face 'elisp-special-variable-declaration - :help (cl-constantly "Special variable declaration") - :namespace 'variable) + :help "Special variable declaration") (elisp-scope-define-symbol-role defface () :doc "Face definitions." - :definition 'defface :face 'elisp-defface - :help (cl-constantly "Face definition") - :imenu "Face" - :namespace 'face) + :help "Face definition") (elisp-scope-define-symbol-role 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)))) @@ -511,13 +477,11 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (if-let* ((doc (documentation sym))) (format "Major mode `%S'.\n\n%s" sym doc) "Major mode")) - "Major mode")) - :namespace 'function) + "Major mode"))) (elisp-scope-define-symbol-role major-mode-definition (major-mode) :doc "Major mode definitions." - :help (cl-constantly "Major mode definition") - :imenu "Major Mode") + :help "Major mode definition") (elisp-scope-define-symbol-role block () :doc "`cl-block' block names." @@ -526,22 +490,16 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (elisp-scope-define-symbol-role icon () :doc "Icon names." - :definition 'deficon :face 'elisp-icon - :help (cl-constantly "Icon") - :namespace 'icon) + :help "Icon") (elisp-scope-define-symbol-role deficon () :doc "Icon definitions." - :definition 'deficon :face 'elisp-deficon - :help (cl-constantly "Icon definition") - :imenu "Icon" - :namespace 'icon) + :help "Icon definition") (elisp-scope-define-symbol-role 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)))) @@ -549,20 +507,15 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (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) + "OClosure type"))) (elisp-scope-define-symbol-role defoclosure () :doc "OClosure type definitions." - :definition 'defoclosure :face 'elisp-defoclosure - :help (cl-constantly "OClosure type definition") - :imenu "OClosure type" - :namespace 'oclosure) + :help "OClosure type definition") (elisp-scope-define-symbol-role 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)))) @@ -570,20 +523,15 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (if-let* ((doc (coding-system-doc-string sym))) (format "Coding system `%S'.\n\n%s" sym doc) "Coding system")) - "Coding system")) - :namespace 'coding) + "Coding system"))) (elisp-scope-define-symbol-role defcoding () :doc "Coding system definitions." - :definition 'defcoding :face 'elisp-defcoding - :help (cl-constantly "Coding system definition") - :imenu "Coding system" - :namespace 'coding) + :help "Coding system definition") (elisp-scope-define-symbol-role charset () :doc "Charset names." - :definition 'defcharset :face 'elisp-charset :help (lambda (beg end _def) (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) @@ -591,20 +539,15 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (if-let* ((doc (charset-description sym))) (format "Charset `%S'.\n\n%s" sym doc) "Charset")) - "Charset")) - :namespace 'charset) + "Charset"))) (elisp-scope-define-symbol-role defcharset () :doc "Charset definitions." - :definition 'defcharset :face 'elisp-defcharset - :help (cl-constantly "Charset definition") - :imenu "Charset" - :namespace 'charset) + :help "Charset definition") (elisp-scope-define-symbol-role 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)))) @@ -612,16 +555,12 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (if-let* ((doc (get sym 'completion-category-documentation))) (format "Completion category `%S'.\n\n%s" sym doc) "Completion category")) - "Completion category")) - :namespace 'completion-category) + "Completion category"))) (elisp-scope-define-symbol-role 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) + :help "Completion category definition") (defvar elisp-scope-counter nil) @@ -2575,10 +2514,6 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (:face (if-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-face-1 q) (elisp-scope-1 (cadr props)))) - (:definition - (if-let* ((q (elisp-scope--unquote (cadr props)))) - (dolist (st (ensure-list q)) (elisp-scope-report-s st 'symbol-role)) - (elisp-scope-1 (cadr props)))) (otherwise (elisp-scope-1 (cadr props)))) (setq props (cddr props)))) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index b6a89b62112..2b452bd2a0f 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -295,7 +295,7 @@ expand some macro calls in your code to analyze the expanded forms. In untrusted buffers, for security reasons, macro-expansion is restricted to safe macros only (see `elisp-scope-safe-macro-p'). Hence in untrusted buffers the arguments of some macros might not be analyzed, -and therefore not highighted. +and therefore not highlighted. See the function `elisp-scope-analyze-form' for more details about the code analysis." @@ -510,8 +510,8 @@ code analysis." (when elisp-add-help-echo (put-text-property beg end 'help-echo - (when-let* ((fun (elisp-scope-get-symbol-role-property type :help))) - (funcall fun beg end def))))) + (when-let* ((hlp (elisp-scope-get-symbol-role-property type :help))) + (if (stringp hlp) hlp (funcall hlp beg end def)))))) (defvar font-lock-beg) (defvar font-lock-end) commit 90ba21979f26cede8ce50187ccbae45d712468f2 Author: Martin Rudalics Date: Sun Oct 12 10:16:52 2025 +0200 Make buffer-local decorations show up on new window-system frames (Bug#79606) * lisp/frame.el (make-frame): On window-system frames apply buffer-local values for fringes, scroll bars and margins of root and minibuffer window after the new frame was made (Bug#79606). diff --git a/lisp/frame.el b/lisp/frame.el index f07a59c78d2..b6641ca716a 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1116,6 +1116,34 @@ current buffer even if it is hidden." (normal-erase-is-backspace-setup-frame frame) + (when (window-system frame) + ;; On a window-system frame apply buffer-local values for the + ;; fringes, scroll bars and margins of root and minibuffer window + ;; of the new frame. The 'frame-creation-function' above could + ;; not do that since the frame did not exist yet at the time the + ;; buffers for these windows were set (Bug#79606). + (let* ((root (frame-root-window frame)) + (buffer (window-buffer root))) + (with-current-buffer buffer + (set-window-fringes + root left-fringe-width right-fringe-width fringes-outside-margins) + (set-window-scroll-bars + root scroll-bar-width vertical-scroll-bar + scroll-bar-height horizontal-scroll-bar) + (set-window-margins + root left-margin-width right-margin-width))) + (let* ((mini (minibuffer-window frame)) + (buffer (window-buffer mini))) + (when (eq (window-frame mini) frame) + (with-current-buffer buffer + (set-window-fringes + mini left-fringe-width right-fringe-width fringes-outside-margins) + (set-window-scroll-bars + mini scroll-bar-width vertical-scroll-bar + scroll-bar-height horizontal-scroll-bar) + (set-window-margins + mini left-margin-width right-margin-width))))) + ;; We can run `window-configuration-change-hook' for this frame now. (frame-after-make-frame frame t) (run-hook-with-args 'after-make-frame-functions frame) commit 0d7fc4516c9e4a36bd6d36b041a11ebc5c99d107 Author: Eshel Yaron Date: Sat Oct 11 14:18:53 2025 +0200 Document 'elisp-fontify-semantically' in the Emacs manual * doc/emacs/display.texi (Semantic Font Lock): New node. * doc/emacs/emacs.texi: Update menu. * etc/NEWS: Update relevant entry. * lisp/emacs-lisp/elisp-scope.el: Expand commentary. * doc/misc/elisp-semantic-highlighting.org: Delete it. diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index 8da0495f531..aef1047c17e 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1085,6 +1085,7 @@ program. @menu * Traditional Font Lock:: Font Lock based on regexps and syntax tables. * Parser-based Font Lock:: Font Lock based on external parser. +* Semantic Font Lock:: Font Lock based on semantic analysis. @end menu @node Traditional Font Lock @@ -1209,6 +1210,88 @@ fontification level. takes effect immediately in all the existing buffers and for files you visit in the future in the same session. +@node Semantic Font Lock +@subsection Semantic Font Lock +@cindex semantic highlighting + +@dfn{Semantic highlighting} is a semi-advanced editor feature in which +an editor uses some kind of semantic analysis to understand a program's +source code, and communicates useful information about the meaning of +different tokens to the user by highlighting these tokens according to +their specific role in the program. + +Semantic highlighting is more sophisticated than traditional ``syntax +highlighting'', which only considers the syntactic role of a token, +i.e. how it affects the code's @emph{parsing}, unlike semantic analysis +which takes into account the token's effect on the program's +@emph{execution}. For example, a semantic highlighting implementation +may be able to tell apart local and global variables and give distinct +highlighting to each category, even though the language's @emph{syntax} +doesn't make such a distinction. Semantic highlighting is especially +beneficial in languages in which syntactic constructs can mean +completely different things depending on the context in which they +occur, such as Lisp and Prolog. In such languages, syntactic analysis +alone misses a lot of important information that coders need to reason +about their programs. + +@vindex elisp-fontify-semantically +Emacs implements semantic highlighting for Emacs Lisp as an optional +feature of @code{emacs-lisp-mode}. To enable it, set the option +@code{elisp-fontify-semantically} to non-@code{nil}. + +When this option is enabled, @code{emacs-lisp-mode} analyzes your code +and highlights symbols according to their semantic roles, as part of the +mode's usual Font Lock highlighting. It doesn't effect the highlighting +of strings, comments and other syntactic elements such as brackets; +@code{elisp-fontify-semantically} only affects symbol highlighting. + +The semantic analysis assigns to each symbol a @dfn{symbol role}, such +as ``function'', ``local variable'', ``face name'', etc. Each symbol +role has an associated face property, which is applied to symbols with +that role during semantic highlighting. By default, most of these faces +inherit from appropriate @code{font-lock-*} faces. For example, +locally-bound variables get the @code{elisp-bound-variable} face, which +inherits from @code{font-lock-variable-use-face}. + +@vindex elisp-add-help-echo +The analysis can differentiate between more than 50 such symbol roles, +but you don't need to memorize the appearance of so many faces to +leverage semantic highlighting: you can hover over an highlighted symbol +with the mouse to see a tooltip with the exact role Emacs inferred for +that symbol (@pxref{Tooltips}). If you want to disable this extra +information, set @code{elisp-add-help-echo} to @code{nil}. + +There are a few more points you should keep in mind when using +@code{elisp-fontify-semantically}: + +@itemize @bullet +@item +Syntax errors break semantic analysis, so for best results you may want +to enable @code{electric-pair-mode} to keep your code syntactically +correct while you edit it. @xref{Matching}. + +@item +The analysis uses macro-expansion in some cases, but by default it only +does so in trusted buffers (@pxref{Host Security}). In @emph{untrusted} +buffers, some macro arguments may not be highlighted. See the +documentation string of @code{elisp-scope-safe-macro-p} for more +information about which macros Emacs considers safe to expand for +analysis. + +@item +The analysis is informed by definitions in the current Emacs session, +hence code that uses unloaded libraries may miss some highlighting. + +@item +The analysis assumes that lexical binding is in effect (@pxref{Selecting +Lisp Dialect,,, elisp, the Emacs Lisp Reference Manual}). + +@item +Semantic highlighting requires additional processing over traditional +Font Lock---the current implementation might be slow when editing very +large defuns. +@end itemize + @node Highlight Interactively @section Interactive Highlighting diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index b32c704bd12..28233110570 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -391,6 +391,7 @@ Controlling the Display Font Lock * Traditional Font Lock:: Font Lock based on regexps and syntax tables. * Parser-based Font Lock:: Font Lock based on external parser. +* Semantic Font Lock:: Font Lock based on semantic analysis. Searching and Replacement diff --git a/doc/misc/elisp-semantic-highlighting.org b/doc/misc/elisp-semantic-highlighting.org deleted file mode 100644 index 36886ae6535..00000000000 --- a/doc/misc/elisp-semantic-highlighting.org +++ /dev/null @@ -1,210 +0,0 @@ -#+TITLE: Semantic Highlighting for Emacs Lisp - -This document describes the semantic highlighting facility that Emacs -provides for Emacs Lisp (ELisp), and the ELisp code analysis that powers -this feature. - -* Semantic Highlighting - -The term "semantic highlighting" refers to a semi-advanced feature of -code editors, in which the editor uses some kind of semantic analysis to -understand a program's source code, and communicates useful information -about the meaning of different tokens to the user by highlighting these -tokens according to their specific role in the program. - -Semantic highlighting is more sophisticated than traditional "syntax -highlighting", which only considers the syntactic role of a token, -i.e. how it affects the code's /parsing/, unlike semantic analysis which -takes into account the token's effect on the program's /execution/. For -example, a semantic highlighting implementation may be able to tell -apart local and global variables and give distinct highlighting to each -category, even though the language's /syntax/ doesn't make such a -distinction. Semantic highlighting is especially beneficial in -languages in which syntactic constructs can mean completely different -things depending on the context in which they occur, such as Lisp and -Prolog. In such languages, syntactic analysis alone misses a lot of -important information that coders need to reason about their programs. - -* Highlighting ELisp - -Emacs implements semantic highlighting for Emacs Lisp as an optional -feature of =emacs-lisp-mode=. To enable it, set the option -=elisp-fontify-semantically= to non-nil. - -When this option is enabled, =emacs-lisp-mode= analyzes your code and -highlights symbols according to their semantic roles, as part of the -mode's usual =font-lock= highlighting. It doesn't effect the -highlighting of strings, comments and other syntactic elements such as -brackets; =elisp-fontify-semantically= only affects symbol highlighting. -Also note that this option assumes that lexical-binding is in effect. - -** Symbol Roles - -The semantic analysis assigns to each symbol a "symbol role", such as -=function=, =bound-variable=, =binding-variable=, =face=, etc. Each -symbol role has an associated face, which is applied to symbols with -that role during semantic highlighting. By default, most of these faces -inherit from appropriate =font-lock-*= faces. For example, -=binding-variable= symbols get the =elisp-binding-variable= face, which -inherits from =font-lock-variable-name-face=. - -To define new symbol roles, see the macro =elisp-scope-define-symbol-role=. - -** Helpful Annotations - -The analysis can differentiate between more than 50 symbol roles, but -you don't need to memorize the appearance of so many faces to leverage -semantic highlighting. During semantic highlighting, Emacs annotates -each highlighted symbol with a =help-echo= text property that describes -the role of that symbol, so you can see exactly which role was inferred -for a given symbol just by hovering over it with your mouse. You can -control these =help-echo= annotations by setting =elisp-add-help-echo=. - -** Bonus Feature: Highlighting Occurrences of the Local Variable at Point - -If you enable =cursor-sensor-mode= along with -=elisp-fontify-semantically=, then when you move point to a local -variable Emacs will apply special highlighting to all occurrences of -that variable in its local scope. This lets you see at a glance where a -certain local variable is used. - -* ELisp Code Analysis - -The analysis that powers =elisp-fontify-semantically= is implemented in -the library ~elisp-scope.el~. The entry point of the analysis in the -function =elisp-scope-analyze-form=, it takes a caller-provided callback -function which will be called to report the information we find about -each analyzed symbol: the callback gets the position and length of the -analyzed symbol, along with its inferred role and, for locally-bound -variables, the position of the binder. =elisp-scope-analyze-form= reads -a form from the current buffer, starting from point, using -=read-positioning-symbols= to attach position information to symbols. -It then recursively analyzes the form, reporting information about each -symbol it encounters via the caller-provided callback function. For -semantic highlighting, =elisp-scope-analyze-form= is called with a -callback that highlights each reported symbol during analysis. - -Hence, semantic highlighting always processes the whole top-level form -in one go, which might become slow for very large function definitions. -Please report such slowness to bug-gnu-emacs@gnu.org if you encounter it -so we can improve this aspect. - -Also note that, since semantic highlighting reads and analyzes forms, -for best results you should keep your code syntactically correct while -editing it, for example by using =electric-pair-mode=. - -** Recursive Form Analysis - -The core of the analysis that =elisp-scope-analyze-form= performs is -implemented in the recursive function =elisp-scope-1=, which analyzes an -sexp as an evaluated form, propagating contextual information such as -local variable bindings down to analyzed sub-forms. =elisp-scope-1= -takes two arguments: =form=, which is the form to analyze, and =spec=, -which is a specification of the expected value of =form= used to analyze -quoted data. The analysis proceeds as follows: - -- If =form= is a symbol, =elisp-scope-1= reports it as a variable. - See [[*Analyzing Variables][Analyzing Variables]] for details about the exact symbol roles used - for variables. - -- If =form= is a cons cell =(head . args)=, then the analysis depends on - =head=. =head= can have a bespoke "analyzer function" =af=, which is - called as =(af head . args)= and is responsible for (recursively) - analyzing =form=. The analyzer function can be associated to =head= - either locally, as an alist entry in =elisp-scope-local-definitions=, - or globally, via the symbol property =elisp-scope-analyzer=. - - An analyzer may use the functions =elisp-scope-report-s=, - =elisp-scope-1= and =elisp-scope-n= to analyze its arguments, and it - can consult the variable =elisp-scope-output-spec= to obtain the - expected output spec of the analyzed form. For example, the following - is a suitable analyzer for the `identity' function: - - #+begin_src emacs-lisp - (lambda (fsym arg) - (elisp-scope-report-s fsym 'function) - (elisp-scope-1 arg elisp-scope-output-spec)) - #+end_src - - In particular, the analyzer function of =quote= analyzes its argument - according to =elisp-scope-output-spec=, which is bound to the value of - the =spec= argument passed to =elisp-scope-1=. See [[*Analyzing Data][Analyzing Data]] for - more details about this analysis. - -- If =head= is a macro, normally it is expanded, and then the expanded - form is analyzed recursively. Since macro-expansion may involve - arbitrary code execution, only "safe" macro invocations are expanded: - If =head= is one of the macros in =elisp-scope-unsafe-macros=, then it - is never considered safe. Otherwise, =head= is safe if it specified - in the variable =elisp-scope-safe-macros=; or if it has a non-nil - =safe-macro= symbol property; or if the current buffer is trusted - according to =trusted-content-p=. - - If a macro =head= is not safe to expand (and has no associated - analyzer function), then the macro arguments =args= are not analyzed. - Hence semantic highlighting gives best results in trusted buffers, - where all macros can be expanded when needed. - -- If =head= is a function, it is reported as such, and =args= are - recursively analyzed as evaluated forms. - -- Otherwise, if =head= has no associated analyzer function, and it is - not a known macro or function, then it is reported with the =unknown= - symbol role. If the variable =elisp-scope-assume-func= is non-nil, - then unknown =head= is assumed to be a function call, and thus =args= - are analyzed as evaluated forms; otherwise =args= are not analyzed. - -** Analyzing Variables - -When =elisp-scope-1= encounters a variable reference =var=, it checks -whether =var= has a local binding in =elisp-scope-local-bindings=, and -whether =var= is a known special variable. If =var= is a locally-bound -special variable, =elisp-scope-1= reports the role =shadowed-variable=. -If =var= is locally-bound and not a special variable, it gets the role -=bound-variable=. Lastly, if it not locally-bound, then it gets the -role =free-variable=. - -** Analyzing Data - -When analyzer functions invoke =elisp-scope-1/n= to analyze some -sub-forms, they specify the =outspec= argument to convey information but -the expected value of the evaluated sub-form(s), so =elisp-scope-1/n= -will know what to do with a sub-form that is just (quoted) data. - -For example, the analyzer function for =face-attribute= calls -=elisp-scope-1= to analyze its first argument with an =outspec= which -says that a quoted symbol in this position refers to a face name. That -way, in a form such as =(face-attribute 'default :foreground)= the -symbol =default= is reported as a face reference (symbol role =face=). -Moreover, the =outspec= is passed down as appropriate through various -predefined analyzers, so every quoted symbol in a "tail position" of the -first argument to =face-attribute= will also be recognized as a face. -For instance, in the following form, both =success= and =error= are -reported as face references: - -#+begin_src emacs-lisp - (face-attribute (if (something-p) - 'success - (message "oops") - 'error) - :foreground) -#+end_src - -See also the docstring of =elisp-scope-1= for details about the format -of the =outspec= argument. - -* Takeaways - -- Set =elisp-fontify-semantically= to non-nil to enable semantic - highlighting for ELisp. -- It uses various =elisp-*= faces for the various symbol roles it - recognizes (function, macro, local/global variable...); most of these - faces inherit from appropriate =font-lock-*= faces. -- The current implementation can be slow when editing very large defuns. -- Syntax errors break semantic analysis, so =electric-pair-mode= or - similar is recommended. -- In untrusted buffers (as in =trusted-content-p=), some macro arguments - may not be highlighted. -- Highlighting is informed by definitions in the current Emacs session, - hence code that uses unloaded libraries may miss some highlighting. -- You can extend it with new analyzer functions and new symbol roles. diff --git a/etc/NEWS b/etc/NEWS index dde3b783877..ebdb0f4731d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1153,11 +1153,12 @@ 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, and see -its documentation for more information. +the Info node "(emacs) Semantic Font Lock" for more information. ** Text mode diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 3b7e088d5d7..340b9f55558 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -21,9 +21,113 @@ ;;; 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 `elisp-scope-analyze-form', see its docstring for usage -;; information. +;; symbol in ELisp code. + +;; The analysis assigns to each symbol a "symbol role", such as +;; `function', `bound-variable', `binding-variable', `face', etc. Each +;; symbol role has associated properties, such as the `:face' property, +;; which specifies a face that is applied to symbols with that role when +;; using semantic highlighting with `elisp-fontify-semantically'. +;; To define new symbol roles, see `elisp-scope-define-symbol-role'. +;; +;; The entry point of the analysis in the function +;; `elisp-scope-analyze-form'. It takes a caller-provided callback +;; function which will be called to report the information we find about +;; each analyzed symbol: the callback gets the position and length of +;; the analyzed symbol, along with its inferred role and, for +;; locally-bound variables, the position of the binder. +;; `elisp-scope-analyze-form' reads a form from the current buffer, +;; starting from point, using `read-positioning-symbols' to attach +;; position information to symbols. It then recursively analyzes the +;; form, reporting information about each symbol it encounters via the +;; caller-provided callback function. +;; +;; The core of the analysis that `elisp-scope-analyze-form' performs is +;; implemented in the recursive function `elisp-scope-1', which analyzes +;; an sexp as an evaluated form, propagating contextual information such +;; as local variable bindings down to analyzed sub-forms. +;; `elisp-scope-1' takes two arguments: `form', which is the form to +;; analyze, and `outspec', which is a specification of the expected +;; value of `form' used to analyze quoted data. The analysis proceeds +;; as follows: +;; +;; - If `form' is a symbol, `elisp-scope-1' reports it as a variable. +;; +;; - If `form' is a cons cell (head . args), then the analysis depends +;; on `head'. `head' can have a bespoke "analyzer function" `af', +;; which is called as (af head . args) and is responsible for +;; (recursively) analyzing `form'. The analyzer function can be +;; associated to `head' either locally, as an alist entry in +;; `elisp-scope-local-definitions', or globally, via the symbol +;; property `elisp-scope-analyzer'. +;; +;; An analyzer may use the functions `elisp-scope-report-s', +;; `elisp-scope-1' and `elisp-scope-n' to analyze its arguments, and +;; it can consult the variable `elisp-scope-output-spec' to obtain the +;; expected output spec of the analyzed form. For example, the +;; following is a suitable analyzer for the `identity' function: +;; +;; (lambda (fsym arg) +;; (elisp-scope-report-s fsym 'function) +;; (elisp-scope-1 arg elisp-scope-output-spec)) +;; +;; In particular, the analyzer function of `quote' analyzes its +;; argument according to `elisp-scope-output-spec', which is bound to +;; the value of the `outspec' argument passed to `elisp-scope-1'. +;; +;; - If `head' is a macro, normally it is expanded, and then the +;; expanded form is analyzed recursively. Since macro-expansion may +;; involve arbitrary code execution, only "safe" macro invocations are +;; expanded: if `head' is one of the macros in +;; `elisp-scope-unsafe-macros', then it is never considered safe. +;; Otherwise, `head' is safe if it specified in the variable +;; `elisp-scope-safe-macros'; or if it has a non-nil `safe-macro' +;; symbol property; or if the current buffer is trusted according to +;; `trusted-content-p'. If a macro `head' is not safe to expand (and +;; has no associated analyzer function), then the macro arguments +;; `args' are not analyzed. +;; +;; - If `head' is a function, it is reported as such, and `args' are +;; recursively analyzed as evaluated forms. +;; +;; - Otherwise, if `head' has no associated analyzer function, and it is +;; not a known macro or function, then it is reported with the `unknown' +;; symbol role. If the variable `elisp-scope-assume-func' is non-nil, +;; then unknown `head' is assumed to be a function call, and thus `args' +;; are analyzed as evaluated forms; otherwise `args' are not analyzed. +;; +;; When `elisp-scope-1' encounters a variable reference `var', it checks +;; whether `var' has a local binding in `elisp-scope-local-bindings', and +;; whether `var' is a known special variable. If `var' is a locally-bound +;; special variable, `elisp-scope-1' reports the role `shadowed-variable'. +;; If `var' is locally-bound and not a special variable, it gets the role +;; `bound-variable'. Lastly, if it not locally-bound, then it gets the +;; role `free-variable'. +;; +;; When analyzer functions invoke `elisp-scope-1/n' to analyze some +;; sub-forms, they specify the `outspec' argument to convey information +;; but the expected value of the evaluated sub-form(s), so +;; `elisp-scope-1/n' will know what to do with a sub-form that is just +;; (quoted) data. For example, the analyzer function for +;; `face-attribute' calls `elisp-scope-1' to analyze its first argument +;; with an `outspec' which says that a quoted symbol in this position +;; refers to a face name. +;; That way, in a form such as (face-attribute 'default :foreground), +;; the symbol `default' is reported as a face reference (`face' role). +;; Moreover, the `outspec' is passed down as appropriate through various +;; predefined analyzers, so every quoted symbol in a "tail position" of +;; the first argument to `face-attribute' will also be recognized as a +;; face. For instance, in the following form, both `success' and +;; `error' are reported as face references: +;; +;; (face-attribute (if (something-p) +;; 'success +;; (message "oops") +;; 'error) +;; :foreground) +;; +;; See also the docstring of `elisp-scope-1' for details about the +;; format of the `outspec' argument. ;;; Code: commit e7df895c2ed9f9491fc1a585c2bff753ad7a5c3f Author: Eshel Yaron Date: Wed Oct 8 17:58:58 2025 +0200 ; (elisp-scope-if-let): Fix case where bindings entry is a symbol * lisp/emacs-lisp/elisp-scope.el (elisp-scope-if-let): Fix handling of a plain symbol as one the bindings in an 'if-let*' form, as in (if-let* (foo) 'bar). * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el: Test it. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 3a695f4001a..3b7e088d5d7 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2270,14 +2270,18 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (defun elisp-scope-if-let (bindings then else outspec) (if (consp bindings) (let* ((binding (car bindings)) - (sym (when (cdr binding) (car binding))) - (form (if (cdr binding) (cadr binding) (car binding))) - (bare (bare-symbol sym)) + (sym (if (consp binding) + (when (cdr binding) (car binding)) + binding)) + (form (when (consp binding) + (if (cdr binding) (cadr binding) (car binding)))) + (bare (elisp-scope-sym-bare sym)) (len (length (symbol-name bare))) (beg (elisp-scope-sym-pos sym))) (when beg (elisp-scope-binding bare beg len)) - (elisp-scope-1 form) - (let ((elisp-scope-local-bindings (elisp-scope-local-new bare beg elisp-scope-local-bindings))) + (when form (elisp-scope-1 form)) + (let ((elisp-scope-local-bindings + (elisp-scope-local-new bare beg elisp-scope-local-bindings))) (elisp-scope-if-let (cdr bindings) then else outspec))) (elisp-scope-1 then outspec) (elisp-scope-n else outspec))) diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index e07438a2fc5..a41fb05ce18 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -115,7 +115,9 @@ (when-let* ((foo (symbol-at-point)) ;; ^ (elisp-macro-call font-lock-keyword-face) ;; ^ elisp-binding-variable - +;; ^ elisp-function-reference + current-prefix-arg +;; ^ elisp-shadowing-variable ((commandp foo))) ;; ^ elisp-function-reference ;; ^ elisp-bound-variable commit 240bf0679c5f1f39122526c5bdde67cc10c8236c Author: Eshel Yaron Date: Wed Oct 8 15:46:45 2025 +0200 ; * lisp/emacs-lisp/elisp-scope.el (if-let*): Add comment. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index f689f4bb34f..3a695f4001a 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2258,6 +2258,12 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 file '(symbol . feature)) (elisp-scope-1 form 'code)) +;; We use a bespoke analyzer for `if-let*' instead of letting +;; `elisp-scope-1' expand it because `if-let*' expands to a form that +;; uses each binding symbol also as a bound symbol, and hence after +;; macro-expansion, we would analyze the same symbol(-with-position) +;; first as a `binding-variable' and then as `bound-variable'. With +;; this bespoke analyzer, we only analyze it as a `binding-variable'. (elisp-scope-define-macro-analyzer if-let* (&optional varlist then &rest else) (elisp-scope-if-let varlist then else elisp-scope-output-spec)) commit 61caa91875ceb61181c2d88b5e69daabdcb9b721 Author: Eshel Yaron Date: Tue Oct 7 23:28:07 2025 +0200 ; elisp-scope.el: Fix 'wrong-type-argument' in local function analyzers * lisp/emacs-lisp/elisp-scope.el (elisp-scope--local-function-analyzer): New function. (elisp-scope-flet, elisp-scope-labels) (elisp-scope-named-let): Use it. (elisp-scope-cl-macrolet): Check that argument is 'symbol-with-pos-p' before calling 'symbol-with-pos-pos'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 3b757e646c5..f689f4bb34f 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -747,12 +747,19 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-1 (car exps))) (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) (elisp-scope-with-local-definition bare - (lambda (f &rest args) - (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) - (elisp-scope-n args)) + (elisp-scope--local-function-analyzer pos) (elisp-scope-flet (cdr defs) body outspec)))) (elisp-scope-n body outspec))) +(defun elisp-scope--local-function-analyzer (pos) + (lambda (f &rest args) + (when (symbol-with-pos-p f) + (elisp-scope-report 'function + (symbol-with-pos-pos f) + (length (symbol-name (bare-symbol f))) + pos)) + (elisp-scope-n args))) + (defun elisp-scope-labels (defs forms outspec) (if defs (let* ((def (car defs)) @@ -766,9 +773,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'function beg len beg)) (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) (elisp-scope-with-local-definition bare - (lambda (f &rest args) - (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) - (elisp-scope-n args)) + (elisp-scope--local-function-analyzer pos) (elisp-scope-lambda args body) (elisp-scope-flet (cdr defs) forms outspec)))) (elisp-scope-n forms outspec))) @@ -1047,12 +1052,9 @@ Optional argument LOCAL is a local context to extend." (when-let* ((sym (car (ensure-list binding))) (bare (elisp-scope-sym-bare sym))) (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos sym) l)))) - (let ((pos (or beg (cons 'gen (incf elisp-scope-counter)))) - (len (length (symbol-name bare)))) + (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) (elisp-scope-with-local-definition bare - (lambda (f &rest args) - (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) - (elisp-scope-n args)) + (elisp-scope--local-function-analyzer pos) (let ((elisp-scope-local-bindings l)) (elisp-scope-n body outspec))))))) (defun elisp-scope-rx (regexps) @@ -1550,7 +1552,8 @@ Optional argument LOCAL is a local context to extend." (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) (elisp-scope-with-local-definition bare (lambda (f &rest _) - (elisp-scope-report 'macro (symbol-with-pos-pos f) len pos)) + (when (symbol-with-pos-p f) + (elisp-scope-report 'macro (symbol-with-pos-pos f) len pos))) (elisp-scope-cl-macrolet (cdr bindings) body outspec)))))) (elisp-scope-n body outspec))) commit d1d06099d65c298c7260c26c131d4e5779b0f944 Author: Eshel Yaron Date: Tue Oct 7 23:57:35 2025 +0200 ; Add semantic highlighting test with 'when-let*' * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el: Add test form with 'when-let*'. * test/lisp/progmodes/elisp-mode-tests.el (elisp-test-font-lock): Trust temporary test buffer. diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index d72e8d49fb4..e07438a2fc5 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -111,3 +111,13 @@ ;; ^ elisp-macro-call (foo)))) ;; ^ elisp-macro-call + +(when-let* ((foo (symbol-at-point)) +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ elisp-binding-variable + + ((commandp foo))) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + foo) +;; ^ elisp-bound-variable diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index e7ae7bb79ba..0e1bff600b1 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -1149,10 +1149,11 @@ evaluation of BODY." (should-error (scan-sexps (+ (point-min) 3) 1)))) (ert-deftest elisp-test-font-lock () - (let ((elisp-fontify-semantically t)) - (ert-font-lock-test-file - (ert-resource-file "semantic-highlighting.el") - 'emacs-lisp-mode))) + (ert-font-lock-test-file (ert-resource-file "semantic-highlighting.el") + (lambda () + (emacs-lisp-mode) + (setq-local trusted-content :all + elisp-fontify-semantically t)))) (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here commit 94d314d756bfb1d3bd817a9749fb7623ee16d94f Author: Eshel Yaron Date: Tue Oct 7 23:33:00 2025 +0200 ; elisp-scope.el: Fix handling of 'if-let' and friends * lisp/emacs-lisp/elisp-scope.el (elisp-scope-if-let): New function, used to analyze 'if-let*' forms. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 76d99e0b004..3b757e646c5 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2255,6 +2255,24 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 file '(symbol . feature)) (elisp-scope-1 form 'code)) +(elisp-scope-define-macro-analyzer if-let* (&optional varlist then &rest else) + (elisp-scope-if-let varlist then else elisp-scope-output-spec)) + +(defun elisp-scope-if-let (bindings then else outspec) + (if (consp bindings) + (let* ((binding (car bindings)) + (sym (when (cdr binding) (car binding))) + (form (if (cdr binding) (cadr binding) (car binding))) + (bare (bare-symbol sym)) + (len (length (symbol-name bare))) + (beg (elisp-scope-sym-pos sym))) + (when beg (elisp-scope-binding bare beg len)) + (elisp-scope-1 form) + (let ((elisp-scope-local-bindings (elisp-scope-local-new bare beg elisp-scope-local-bindings))) + (elisp-scope-if-let (cdr bindings) then else outspec))) + (elisp-scope-1 then outspec) + (elisp-scope-n else outspec))) + (elisp-scope-define-macro-analyzer define-globalized-minor-mode (global mode turn-on &rest body) (elisp-scope-report-s mode 'function) (elisp-scope-report-s turn-on 'function) commit f18e658533c46b0b6ebfa9116e0fcc4f5203122f Author: Eshel Yaron Date: Tue Oct 7 12:13:43 2025 +0200 ; Fix typos in docstrings of some faces. * lisp/progmodes/elisp-mode.el (elisp-symbol-role) (elisp-symbol-role-definition, elisp-non-local-exit) (elisp-shadowing-variable, elisp-shadowed-variable) (elisp-icon): Fix docstring. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 0f10c1cfbda..b6a89b62112 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -323,16 +323,16 @@ code analysis." "Face for highlighting face names in Emacs Lisp code.") (defface elisp-symbol-role '((t :foreground "#00008b" :inherit font-lock-function-call-face)) - "Face for highlighting symbol type names in Emacs Lisp code.") + "Face for highlighting symbol role names in Emacs Lisp code.") (defface elisp-symbol-role-definition '((t :foreground "#00008b" :inherit font-lock-function-name-face)) - "Face for highlighting symbol type names in Emacs Lisp code.") + "Face for highlighting symbol role definitions 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.") + "Face for highlighting calls to functions that do not return.") (defface elisp-unknown-call '((t :inherit elisp-function-reference :foreground "#2f4f4f")) "Face for highlighting unknown functions/macros in Emacs Lisp code.") @@ -365,11 +365,11 @@ code analysis." (defface elisp-shadowing-variable '((t :inherit elisp-binding-variable :underline t)) - "Face for highlighting binding occurrences of variables in Emacs Lisp code.") + "Face for highlighting local bindings that shadow special variables.") (defface elisp-shadowed-variable '((t :inherit elisp-bound-variable :underline t)) - "Face for highlighting bound occurrences of variables in Emacs Lisp code.") + "Face for highlighting special variables that are shadowed by a local binding.") (defface elisp-variable-at-point '((t :inherit bold)) "Face for highlighting (all occurrences of) the variable at point.") @@ -417,7 +417,7 @@ code analysis." "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.") + "Face for highlighting icon names in Emacs Lisp code.") (defface elisp-deficon '((t :inherit elisp-icon)) "Face for highlighting icon definitions in Emacs Lisp code.") commit 186cdf599a244c711e2501a6df65da6497c26866 Author: Eshel Yaron Date: Tue Oct 7 12:09:31 2025 +0200 ; * doc/misc/elisp-semantic-highlighting.org: Fix typos. diff --git a/doc/misc/elisp-semantic-highlighting.org b/doc/misc/elisp-semantic-highlighting.org index 058361fd72b..36886ae6535 100644 --- a/doc/misc/elisp-semantic-highlighting.org +++ b/doc/misc/elisp-semantic-highlighting.org @@ -12,7 +12,7 @@ understand a program's source code, and communicates useful information about the meaning of different tokens to the user by highlighting these tokens according to their specific role in the program. -Semantic highlighting is more sophisticated then traditional "syntax +Semantic highlighting is more sophisticated than traditional "syntax highlighting", which only considers the syntactic role of a token, i.e. how it affects the code's /parsing/, unlike semantic analysis which takes into account the token's effect on the program's /execution/. For @@ -22,7 +22,7 @@ category, even though the language's /syntax/ doesn't make such a distinction. Semantic highlighting is especially beneficial in languages in which syntactic constructs can mean completely different things depending on the context in which they occur, such as Lisp and -Prolog. In such language, syntactic analysis alone misses a lot of +Prolog. In such languages, syntactic analysis alone misses a lot of important information that coders need to reason about their programs. * Highlighting ELisp @@ -43,10 +43,10 @@ Also note that this option assumes that lexical-binding is in effect. The semantic analysis assigns to each symbol a "symbol role", such as =function=, =bound-variable=, =binding-variable=, =face=, etc. Each symbol role has an associated face, which is applied to symbols with -that role during semantic. By default, most of these faces inherit from -appropriate =font-lock-*= faces. For example, =binding-variable= -symbols get the =elisp-binding-variable= face, which inherits from -=font-lock-variable-name-face=. +that role during semantic highlighting. By default, most of these faces +inherit from appropriate =font-lock-*= faces. For example, +=binding-variable= symbols get the =elisp-binding-variable= face, which +inherits from =font-lock-variable-name-face=. To define new symbol roles, see the macro =elisp-scope-define-symbol-role=. @@ -55,8 +55,8 @@ To define new symbol roles, see the macro =elisp-scope-define-symbol-role=. The analysis can differentiate between more than 50 symbol roles, but you don't need to memorize the appearance of so many faces to leverage semantic highlighting. During semantic highlighting, Emacs annotates -each highlighted symbol with an =help-echo= text property that describes -the role of that symbol, so you an see exactly which role was inferred +each highlighted symbol with a =help-echo= text property that describes +the role of that symbol, so you can see exactly which role was inferred for a given symbol just by hovering over it with your mouse. You can control these =help-echo= annotations by setting =elisp-add-help-echo=. commit 5944cd33dd451050096418435570925f23692c3b Author: Eshel Yaron Date: Mon Oct 6 16:59:00 2025 +0200 Add documentation about ELisp semantic highlighting diff --git a/doc/misc/elisp-semantic-highlighting.org b/doc/misc/elisp-semantic-highlighting.org new file mode 100644 index 00000000000..058361fd72b --- /dev/null +++ b/doc/misc/elisp-semantic-highlighting.org @@ -0,0 +1,210 @@ +#+TITLE: Semantic Highlighting for Emacs Lisp + +This document describes the semantic highlighting facility that Emacs +provides for Emacs Lisp (ELisp), and the ELisp code analysis that powers +this feature. + +* Semantic Highlighting + +The term "semantic highlighting" refers to a semi-advanced feature of +code editors, in which the editor uses some kind of semantic analysis to +understand a program's source code, and communicates useful information +about the meaning of different tokens to the user by highlighting these +tokens according to their specific role in the program. + +Semantic highlighting is more sophisticated then traditional "syntax +highlighting", which only considers the syntactic role of a token, +i.e. how it affects the code's /parsing/, unlike semantic analysis which +takes into account the token's effect on the program's /execution/. For +example, a semantic highlighting implementation may be able to tell +apart local and global variables and give distinct highlighting to each +category, even though the language's /syntax/ doesn't make such a +distinction. Semantic highlighting is especially beneficial in +languages in which syntactic constructs can mean completely different +things depending on the context in which they occur, such as Lisp and +Prolog. In such language, syntactic analysis alone misses a lot of +important information that coders need to reason about their programs. + +* Highlighting ELisp + +Emacs implements semantic highlighting for Emacs Lisp as an optional +feature of =emacs-lisp-mode=. To enable it, set the option +=elisp-fontify-semantically= to non-nil. + +When this option is enabled, =emacs-lisp-mode= analyzes your code and +highlights symbols according to their semantic roles, as part of the +mode's usual =font-lock= highlighting. It doesn't effect the +highlighting of strings, comments and other syntactic elements such as +brackets; =elisp-fontify-semantically= only affects symbol highlighting. +Also note that this option assumes that lexical-binding is in effect. + +** Symbol Roles + +The semantic analysis assigns to each symbol a "symbol role", such as +=function=, =bound-variable=, =binding-variable=, =face=, etc. Each +symbol role has an associated face, which is applied to symbols with +that role during semantic. By default, most of these faces inherit from +appropriate =font-lock-*= faces. For example, =binding-variable= +symbols get the =elisp-binding-variable= face, which inherits from +=font-lock-variable-name-face=. + +To define new symbol roles, see the macro =elisp-scope-define-symbol-role=. + +** Helpful Annotations + +The analysis can differentiate between more than 50 symbol roles, but +you don't need to memorize the appearance of so many faces to leverage +semantic highlighting. During semantic highlighting, Emacs annotates +each highlighted symbol with an =help-echo= text property that describes +the role of that symbol, so you an see exactly which role was inferred +for a given symbol just by hovering over it with your mouse. You can +control these =help-echo= annotations by setting =elisp-add-help-echo=. + +** Bonus Feature: Highlighting Occurrences of the Local Variable at Point + +If you enable =cursor-sensor-mode= along with +=elisp-fontify-semantically=, then when you move point to a local +variable Emacs will apply special highlighting to all occurrences of +that variable in its local scope. This lets you see at a glance where a +certain local variable is used. + +* ELisp Code Analysis + +The analysis that powers =elisp-fontify-semantically= is implemented in +the library ~elisp-scope.el~. The entry point of the analysis in the +function =elisp-scope-analyze-form=, it takes a caller-provided callback +function which will be called to report the information we find about +each analyzed symbol: the callback gets the position and length of the +analyzed symbol, along with its inferred role and, for locally-bound +variables, the position of the binder. =elisp-scope-analyze-form= reads +a form from the current buffer, starting from point, using +=read-positioning-symbols= to attach position information to symbols. +It then recursively analyzes the form, reporting information about each +symbol it encounters via the caller-provided callback function. For +semantic highlighting, =elisp-scope-analyze-form= is called with a +callback that highlights each reported symbol during analysis. + +Hence, semantic highlighting always processes the whole top-level form +in one go, which might become slow for very large function definitions. +Please report such slowness to bug-gnu-emacs@gnu.org if you encounter it +so we can improve this aspect. + +Also note that, since semantic highlighting reads and analyzes forms, +for best results you should keep your code syntactically correct while +editing it, for example by using =electric-pair-mode=. + +** Recursive Form Analysis + +The core of the analysis that =elisp-scope-analyze-form= performs is +implemented in the recursive function =elisp-scope-1=, which analyzes an +sexp as an evaluated form, propagating contextual information such as +local variable bindings down to analyzed sub-forms. =elisp-scope-1= +takes two arguments: =form=, which is the form to analyze, and =spec=, +which is a specification of the expected value of =form= used to analyze +quoted data. The analysis proceeds as follows: + +- If =form= is a symbol, =elisp-scope-1= reports it as a variable. + See [[*Analyzing Variables][Analyzing Variables]] for details about the exact symbol roles used + for variables. + +- If =form= is a cons cell =(head . args)=, then the analysis depends on + =head=. =head= can have a bespoke "analyzer function" =af=, which is + called as =(af head . args)= and is responsible for (recursively) + analyzing =form=. The analyzer function can be associated to =head= + either locally, as an alist entry in =elisp-scope-local-definitions=, + or globally, via the symbol property =elisp-scope-analyzer=. + + An analyzer may use the functions =elisp-scope-report-s=, + =elisp-scope-1= and =elisp-scope-n= to analyze its arguments, and it + can consult the variable =elisp-scope-output-spec= to obtain the + expected output spec of the analyzed form. For example, the following + is a suitable analyzer for the `identity' function: + + #+begin_src emacs-lisp + (lambda (fsym arg) + (elisp-scope-report-s fsym 'function) + (elisp-scope-1 arg elisp-scope-output-spec)) + #+end_src + + In particular, the analyzer function of =quote= analyzes its argument + according to =elisp-scope-output-spec=, which is bound to the value of + the =spec= argument passed to =elisp-scope-1=. See [[*Analyzing Data][Analyzing Data]] for + more details about this analysis. + +- If =head= is a macro, normally it is expanded, and then the expanded + form is analyzed recursively. Since macro-expansion may involve + arbitrary code execution, only "safe" macro invocations are expanded: + If =head= is one of the macros in =elisp-scope-unsafe-macros=, then it + is never considered safe. Otherwise, =head= is safe if it specified + in the variable =elisp-scope-safe-macros=; or if it has a non-nil + =safe-macro= symbol property; or if the current buffer is trusted + according to =trusted-content-p=. + + If a macro =head= is not safe to expand (and has no associated + analyzer function), then the macro arguments =args= are not analyzed. + Hence semantic highlighting gives best results in trusted buffers, + where all macros can be expanded when needed. + +- If =head= is a function, it is reported as such, and =args= are + recursively analyzed as evaluated forms. + +- Otherwise, if =head= has no associated analyzer function, and it is + not a known macro or function, then it is reported with the =unknown= + symbol role. If the variable =elisp-scope-assume-func= is non-nil, + then unknown =head= is assumed to be a function call, and thus =args= + are analyzed as evaluated forms; otherwise =args= are not analyzed. + +** Analyzing Variables + +When =elisp-scope-1= encounters a variable reference =var=, it checks +whether =var= has a local binding in =elisp-scope-local-bindings=, and +whether =var= is a known special variable. If =var= is a locally-bound +special variable, =elisp-scope-1= reports the role =shadowed-variable=. +If =var= is locally-bound and not a special variable, it gets the role +=bound-variable=. Lastly, if it not locally-bound, then it gets the +role =free-variable=. + +** Analyzing Data + +When analyzer functions invoke =elisp-scope-1/n= to analyze some +sub-forms, they specify the =outspec= argument to convey information but +the expected value of the evaluated sub-form(s), so =elisp-scope-1/n= +will know what to do with a sub-form that is just (quoted) data. + +For example, the analyzer function for =face-attribute= calls +=elisp-scope-1= to analyze its first argument with an =outspec= which +says that a quoted symbol in this position refers to a face name. That +way, in a form such as =(face-attribute 'default :foreground)= the +symbol =default= is reported as a face reference (symbol role =face=). +Moreover, the =outspec= is passed down as appropriate through various +predefined analyzers, so every quoted symbol in a "tail position" of the +first argument to =face-attribute= will also be recognized as a face. +For instance, in the following form, both =success= and =error= are +reported as face references: + +#+begin_src emacs-lisp + (face-attribute (if (something-p) + 'success + (message "oops") + 'error) + :foreground) +#+end_src + +See also the docstring of =elisp-scope-1= for details about the format +of the =outspec= argument. + +* Takeaways + +- Set =elisp-fontify-semantically= to non-nil to enable semantic + highlighting for ELisp. +- It uses various =elisp-*= faces for the various symbol roles it + recognizes (function, macro, local/global variable...); most of these + faces inherit from appropriate =font-lock-*= faces. +- The current implementation can be slow when editing very large defuns. +- Syntax errors break semantic analysis, so =electric-pair-mode= or + similar is recommended. +- In untrusted buffers (as in =trusted-content-p=), some macro arguments + may not be highlighted. +- Highlighting is informed by definitions in the current Emacs session, + hence code that uses unloaded libraries may miss some highlighting. +- You can extend it with new analyzer functions and new symbol roles. commit fddc5f664eeb978356365c88e7c3505d087ea9aa Author: Eshel Yaron Date: Mon Oct 6 16:49:32 2025 +0200 ; Rename 'elisp-scope--local' to 'elisp-scope-local-bindings' We make this variable "public" since it's part of the interface that we expose to custom analyzers. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 7fa80f496dd..76d99e0b004 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -521,7 +521,14 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (defvar elisp-scope-counter nil) -(defvar elisp-scope--local nil) +(defvar elisp-scope-local-bindings nil + "Alist of locally bound variables. + +This is a list of cons cells (BOUND . BINDER), where BOUND is a symbol +which has a local variable binding in the current context, and BINDER +uniquely identifies the value that BOUND is bound to. Usually, BINDER +is the buffer position in which BOUND is bound, such as a surrounding +`let' or `lambda' form.") (defvar elisp-scope-output-spec nil "Output spec of the form currently analyzed, or nil if unknown. @@ -577,11 +584,11 @@ Optional argument LOCAL is a local context to extend." (if (and (length> name 1) (= (aref name 1) ?.)) ;; Double dot escapes `let-alist'. (let* ((unescaped (intern (substring name 1)))) - (elisp-scope-variable unescaped beg len (alist-get unescaped elisp-scope--local))) + (elisp-scope-variable unescaped beg len (alist-get unescaped elisp-scope-local-bindings))) (elisp-scope-report 'bound-variable beg len (list 'let-alist (car elisp-scope-current-let-alist-form) bare) (cdr elisp-scope-current-let-alist-form)))) - (t (elisp-scope-variable bare beg len (alist-get bare elisp-scope--local))))))) + (t (elisp-scope-variable bare beg len (alist-get bare elisp-scope-local-bindings))))))) (defun elisp-scope-let-1 (local bindings body) (if bindings @@ -594,11 +601,11 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-1 (cadr binding)) (elisp-scope-let-1 (if bare (elisp-scope-local-new bare beg local) local) (cdr bindings) body)) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (elisp-scope-n body elisp-scope-output-spec)))) (defun elisp-scope-let (bindings body) - (elisp-scope-let-1 elisp-scope--local bindings body)) + (elisp-scope-let-1 elisp-scope-local-bindings bindings body)) (defun elisp-scope-let* (bindings body) (if bindings @@ -609,7 +616,7 @@ Optional argument LOCAL is a local context to extend." (beg (elisp-scope-sym-pos sym))) (when beg (elisp-scope-binding bare beg len)) (elisp-scope-1 (cadr binding)) - (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (let ((elisp-scope-local-bindings (elisp-scope-local-new bare beg elisp-scope-local-bindings))) (elisp-scope-let* (cdr bindings) body))) (elisp-scope-n body elisp-scope-output-spec))) @@ -622,7 +629,7 @@ Optional argument LOCAL is a local context to extend." (mapc #'elisp-scope-major-mode-name modes)) (defun elisp-scope-lambda (args body &optional outspec) - (let ((l elisp-scope--local)) + (let ((l elisp-scope-local-bindings)) (when (listp args) (dolist (arg args) (when-let* ((bare (bare-symbol arg)) @@ -667,13 +674,13 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-sharpquote (cadr spec)))) ((compiler-macro gv-expander gv-setter) ;; Use the extended lexical environment `l'. - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-sharpquote (cadr spec)))) (modes (mapc #'elisp-scope-major-mode-name (cdr spec))) (interactive-args (dolist (arg-form (cdr spec)) (when-let* ((arg (car-safe arg-form))) - (let ((elisp-scope--local l)) (elisp-scope-s arg)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-s arg)) (when (consp (cdr arg-form)) (elisp-scope-1 (cadr arg-form))))))))) (setq body (cdr body))) @@ -697,7 +704,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'ampersand beg len) (elisp-scope-report 'binding-variable beg len beg))))))) ;; Handle BODY. - (let ((elisp-scope--local l)) (elisp-scope-n body outspec)))) + (let ((elisp-scope-local-bindings l)) (elisp-scope-n body outspec)))) (defun elisp-scope-defun (name args body) (when-let* ((beg (elisp-scope-sym-pos name)) @@ -801,12 +808,12 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-loop-for-and (rest) (if (eq (elisp-scope-sym-bare (car rest)) 'and) - (elisp-scope-loop-for elisp-scope--local (cadr rest) (cddr rest)) + (elisp-scope-loop-for elisp-scope-local-bindings (cadr rest) (cddr rest)) (elisp-scope-loop rest))) (defun elisp-scope-loop-for-by (local expr rest) (elisp-scope-1 expr) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (elisp-scope-loop-for-and rest))) (defun elisp-scope-loop-for-to (local expr rest) @@ -816,7 +823,7 @@ Optional argument LOCAL is a local context to extend." (cond ((eq bare 'by) (elisp-scope-loop-for-by local (car more) (cdr more))) - (t (let ((elisp-scope--local local)) + (t (let ((elisp-scope-local-bindings local)) (elisp-scope-loop-for-and rest)))))) (defun elisp-scope-loop-for-from (local expr rest) @@ -828,7 +835,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-loop-for-to local (car more) (cdr more))) ((eq bare 'by) (elisp-scope-loop-for-by local (car more) (cdr more))) - (t (let ((elisp-scope--local local)) + (t (let ((elisp-scope-local-bindings local)) (elisp-scope-loop-for-and rest)))))) (defun elisp-scope-loop-for-= (local expr rest) @@ -838,7 +845,7 @@ Optional argument LOCAL is a local context to extend." (cond ((eq bare 'then) (elisp-scope-loop-for-by local (car more) (cdr more))) - (t (let ((elisp-scope--local local)) + (t (let ((elisp-scope-local-bindings local)) (elisp-scope-loop-for-and rest)))))) (defun elisp-scope-loop-for-being-the-hash-keys-of-using (form rest) @@ -846,14 +853,14 @@ Optional argument LOCAL is a local context to extend." (bare (elisp-scope-sym-bare var)) (beg (elisp-scope-sym-pos var))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) - (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (let ((elisp-scope-local-bindings (elisp-scope-local-new bare beg elisp-scope-local-bindings))) (elisp-scope-loop-for-and rest)))) (defun elisp-scope-loop-for-being-the-hash-keys-of (local expr rest) (elisp-scope-1 expr) (when-let* ((bare (elisp-scope-sym-bare (car rest))) (more (cdr rest))) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (cond ((eq bare 'using) (elisp-scope-loop-for-being-the-hash-keys-of-using (car more) (cdr more))) @@ -869,7 +876,7 @@ Optional argument LOCAL is a local context to extend." (when-let* ((bare (elisp-scope-sym-bare word))) (cond ((memq bare '(buffer buffers)) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (elisp-scope-loop-for-and rest))) ((memq bare '( hash-key hash-keys hash-value hash-values @@ -927,7 +934,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-loop (cdr more))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) (let ((elisp-scope-loop-into-vars (cons bare elisp-scope-loop-into-vars)) - (elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (elisp-scope-local-bindings (elisp-scope-local-new bare beg elisp-scope-local-bindings))) (elisp-scope-loop (cdr more))))) (elisp-scope-loop rest)))) @@ -939,15 +946,15 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-loop-with (var rest) (let* ((bare (elisp-scope-sym-bare var)) (beg (symbol-with-pos-pos var)) - (l (elisp-scope-local-new bare beg elisp-scope--local)) + (l (elisp-scope-local-new bare beg elisp-scope-local-bindings)) (eql (car rest))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) (if (eq (elisp-scope-sym-bare eql) '=) (let* ((val (cadr rest)) (more (cddr rest))) (elisp-scope-1 val) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-loop-with-and more))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-loop-with-and rest))))) (defun elisp-scope-loop-do (form rest) @@ -988,9 +995,9 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-loop-if (keyword condition rest) (elisp-scope-1 condition) (let ((elisp-scope-loop-if-depth (1+ elisp-scope-loop-if-depth)) - (elisp-scope--local + (elisp-scope-local-bindings ;; `if' binds `it'. - (elisp-scope-local-new 'it (elisp-scope-sym-pos keyword) elisp-scope--local))) + (elisp-scope-local-new 'it (elisp-scope-sym-pos keyword) elisp-scope-local-bindings))) (elisp-scope-loop rest))) (defun elisp-scope-loop-end (rest) @@ -1008,7 +1015,7 @@ Optional argument LOCAL is a local context to extend." (rest (cdr forms))) (cond ((memq bare '(for as)) - (elisp-scope-loop-for elisp-scope--local (car rest) (cdr rest))) + (elisp-scope-loop-for elisp-scope-local-bindings (car rest) (cdr rest))) ((memq bare '( repeat while until always never thereis iter-by return)) (elisp-scope-loop-repeat (car rest) (cdr rest))) @@ -1035,7 +1042,7 @@ Optional argument LOCAL is a local context to extend." (bare (bare-symbol sym))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) (elisp-scope-1 (cadr binding)))) - (let ((l elisp-scope--local)) + (let ((l elisp-scope-local-bindings)) (dolist (binding bindings) (when-let* ((sym (car (ensure-list binding))) (bare (elisp-scope-sym-bare sym))) @@ -1046,7 +1053,7 @@ Optional argument LOCAL is a local context to extend." (lambda (f &rest args) (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) (elisp-scope-n args)) - (let ((elisp-scope--local l)) (elisp-scope-n body outspec))))))) + (let ((elisp-scope-local-bindings l)) (elisp-scope-n body outspec))))))) (defun elisp-scope-rx (regexps) (dolist (regexp regexps) (elisp-scope-rx-1 regexp))) @@ -1310,7 +1317,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-binding bare beg len)) (elisp-scope-defmethod-1 (elisp-scope-local-new bare (elisp-scope-sym-pos arg) local) (cdr args) body)))))) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (elisp-scope-n body)))) ;; (defun elisp-scope-defmethod (local name rest) @@ -1335,7 +1342,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-s (car rest)) (setq rest (cdr rest))) ;; ARGUMENTS - (elisp-scope-defmethod-1 elisp-scope--local (car rest) (cdr rest))) + (elisp-scope-defmethod-1 elisp-scope-local-bindings (car rest) (cdr rest))) (defun elisp-scope-cl-defun (name arglist body) (let ((beg (elisp-scope-sym-pos name)) @@ -1368,7 +1375,7 @@ Optional argument LOCAL is a local context to extend." (&whole (elisp-scope-cl-lambda-1 (cdr arglist) more body)))) (when-let* ((beg (elisp-scope-sym-pos head))) (elisp-scope-binding bare beg (length (symbol-name bare)))) - (let ((elisp-scope--local (elisp-scope-local-new bare (elisp-scope-sym-pos head) elisp-scope--local))) + (let ((elisp-scope-local-bindings (elisp-scope-local-new bare (elisp-scope-sym-pos head) elisp-scope-local-bindings))) (elisp-scope-cl-lambda-1 (cdr arglist) more body)))))) (elisp-scope-cl-lambda-1 (list '&rest arglist) more body))) (more (elisp-scope-cl-lambda-1 (car more) (cdr more) body)) @@ -1385,12 +1392,12 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-cl-lambda-optional (arg arglist more body) (let* ((a (ensure-list arg)) (var (car a)) - (l elisp-scope--local) + (l elisp-scope-local-bindings) (init (cadr a)) (svar (caddr a))) (elisp-scope-1 init) (if (consp var) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 var (cons (append (when svar (list svar)) (cons '&optional arglist)) more) @@ -1413,21 +1420,21 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) (cl-case bare ((&rest &body) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-rest (cadr arglist) (cddr arglist) more body))) - (&key (let ((elisp-scope--local l)) + (&key (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) - (&aux (let ((elisp-scope--local l)) + (&aux (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-optional head (cdr arglist) more body))))) (more - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) - (t (let ((elisp-scope--local l)) (elisp-scope-lambda nil body))))))) + (t (let ((elisp-scope-local-bindings l)) (elisp-scope-lambda nil body))))))) (defun elisp-scope-cl-lambda-rest (var arglist more body) - (let* ((l elisp-scope--local)) + (let* ((l elisp-scope-local-bindings)) (if (consp var) (elisp-scope-cl-lambda-1 var (cons arglist more) body) (when-let* ((bare (elisp-scope-sym-bare var))) @@ -1444,22 +1451,22 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) (cl-case bare (&key - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) (&aux - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 (car more) (cdr more) body))))) - (more (let ((elisp-scope--local l)) + (more (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) - (t (let ((elisp-scope--local l)) + (t (let ((elisp-scope-local-bindings l)) (elisp-scope-lambda nil body))))))) (defun elisp-scope-cl-lambda-key (arg arglist more body) (let* ((a (ensure-list arg)) (var (car a)) - (l elisp-scope--local) + (l elisp-scope-local-bindings) (init (cadr a)) (svar (caddr a)) (kw (car-safe var))) @@ -1475,7 +1482,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'constant beg (length (symbol-name bare)))) (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos svar) l))) (if (consp var) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 var (cons (append (when svar (list svar)) (cons '&key arglist)) more) @@ -1498,32 +1505,32 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) (cl-case bare (&aux - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))) (&allow-other-keys - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 (car more) (cdr more) body))))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-key head (cdr arglist) more body))))) - (more (let ((elisp-scope--local l)) + (more (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) - (t (let ((elisp-scope--local l)) + (t (let ((elisp-scope-local-bindings l)) (elisp-scope-lambda nil body))))))) (defun elisp-scope-cl-lambda-aux (arg arglist more body) (let* ((a (ensure-list arg)) (var (car a)) - (l elisp-scope--local) + (l elisp-scope-local-bindings) (init (cadr a))) (elisp-scope-1 init) (if (consp var) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-cl-lambda-1 var (cons arglist more) body)) (when-let* ((bare (elisp-scope-sym-bare var))) (when-let* ((beg (elisp-scope-sym-pos var))) (elisp-scope-binding bare beg (length (symbol-name bare)))) (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos var) l))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (cond (arglist (elisp-scope-cl-lambda-aux (car arglist) (cdr arglist) more body)) (more (elisp-scope-cl-lambda-1 (car more) (cdr more) body)) @@ -2283,13 +2290,13 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-oclosure-lambda-1 (if bare (elisp-scope-local-new bare beg local) local) (cdr bindings) args body)) - (let ((elisp-scope--local local)) + (let ((elisp-scope-local-bindings local)) (elisp-scope-lambda args body)))) (defun elisp-scope-oclosure-lambda (spec args body) (let ((type (car-safe spec))) (elisp-scope-report-s type 'oclosure)) - (elisp-scope-oclosure-lambda-1 elisp-scope--local (cdr-safe spec) args body)) + (elisp-scope-oclosure-lambda-1 elisp-scope-local-bindings (cdr-safe spec) args body)) (elisp-scope-define-macro-analyzer oclosure-lambda (&optional spec args &rest body) (elisp-scope-oclosure-lambda spec args body)) @@ -2441,7 +2448,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (setq props (cddr props)))) (elisp-scope-define-macro-analyzer cl-letf (bindings &rest body) - (let ((l elisp-scope--local)) + (let ((l elisp-scope-local-bindings)) (dolist (binding bindings) (let ((place (car binding))) (if (or (symbol-with-pos-p place) (symbolp place)) @@ -2452,7 +2459,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (setq l (elisp-scope-local-new bare beg l))) (elisp-scope-1 place)) (elisp-scope-1 (cadr binding)))) - (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope-output-spec)))) + (let ((elisp-scope-local-bindings l)) (elisp-scope-n body elisp-scope-output-spec)))) (elisp-scope-define-macro-analyzer setf (&rest args) (elisp-scope-setq args)) @@ -2496,7 +2503,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer seq-let (args sequence &rest body) (elisp-scope-1 sequence) - (let ((l elisp-scope--local)) + (let ((l elisp-scope-local-bindings)) (dolist (arg args) (let* ((bare (elisp-scope-sym-bare arg)) (len (length (symbol-name bare))) @@ -2505,7 +2512,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-report 'ampersand beg len) (when beg (elisp-scope-binding bare beg len)) (setq l (elisp-scope-local-new bare beg l))))) - (let ((elisp-scope--local l)) (elisp-scope-n body)))) + (let ((elisp-scope-local-bindings l)) (elisp-scope-n body)))) (elisp-scope-define-analyzer let-alist (f alist &rest body) (elisp-scope-report-s f 'macro) @@ -2570,7 +2577,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) (let* ((bare (bare-symbol var)) (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) - (l (elisp-scope-local-new bare beg elisp-scope--local))) + (l (elisp-scope-local-new bare beg elisp-scope-local-bindings))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) (elisp-scope-1 bodyform elisp-scope-output-spec) (dolist (handler handlers) @@ -2582,7 +2589,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." ((booleanp cbare)) ((keywordp cbare) (elisp-scope-report 'constant cbeg clen)) (t (elisp-scope-report 'condition cbeg clen))))) - (let ((elisp-scope--local l)) + (let ((elisp-scope-local-bindings l)) (elisp-scope-n (cdr handler) elisp-scope-output-spec))))) (elisp-scope-define-special-form-analyzer function (&optional arg) @@ -2618,7 +2625,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." ) (cl-defmethod elisp-scope--handle-quoted ((_spec (eql 'code)) arg) - (let ((elisp-scope--local nil) + (let ((elisp-scope-local-bindings nil) (elisp-scope-current-let-alist-form nil) (elisp-scope-local-definitions nil) (elisp-scope-block-alist nil) commit b65318fc6dfa52825d3914e79698238a2f9fd0aa Author: Eshel Yaron Date: Mon Oct 6 13:31:18 2025 +0200 ; Update a couple of face definitions for ELisp variables * lisp/progmodes/elisp-mode.el (elisp-bound-variable) (elisp-free-variable): Inherit from 'font-lock-variable-use-face', override foreground face to keep current appearance. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 94e3aff59c5..0f10c1cfbda 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -306,7 +306,8 @@ code analysis." (((background dark)) :background "#00422a")) "Face for highlighting the symbol at mouse in Emacs Lisp code.") -(defface elisp-free-variable '((t :inherit underline)) +(defface elisp-free-variable + '((t :underline t :foreground "black" :inherit font-lock-variable-use-face)) "Face for highlighting free variables in Emacs Lisp code.") (defface elisp-special-variable-declaration '((t :inherit elisp-free-variable)) @@ -358,7 +359,8 @@ code analysis." '((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)) +(defface elisp-bound-variable + '((t :slant italic :foreground "black" :inherit font-lock-variable-use-face)) "Face for highlighting bound occurrences of variables in Emacs Lisp code.") (defface elisp-shadowing-variable commit 8dccb56662051c02677a4140e16cb10755f656e4 Author: Eshel Yaron Date: Mon Oct 6 12:38:28 2025 +0200 ; Drop 'elisp-scope-local-functions' * lisp/emacs-lisp/elisp-scope.el (elisp-scope-local-functions): Remove it, superseded by 'elisp-scope-local-definitions'. (elisp-scope-sharpquote, elisp-scope-1): Update accordingly. (elisp-scope-analyze-form): Fix typo in docstring. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 8251e36fd88..7fa80f496dd 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -521,8 +521,6 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (defvar elisp-scope-counter nil) -(defvar elisp-scope-local-functions nil) - (defvar elisp-scope--local nil) (defvar elisp-scope-output-spec nil @@ -795,7 +793,6 @@ Optional argument LOCAL is a local context to extend." (let ((bare (bare-symbol arg))) (cond ((or (functionp bare) - (memq bare elisp-scope-local-functions) (assq bare elisp-scope-local-definitions) elisp-scope-assume-func) (elisp-scope-report-s arg 'function)) @@ -2807,7 +2804,7 @@ are analyzed." (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) (elisp-scope-1 expanded outspec))) ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)))) - ((or (functionp bare) (memq bare elisp-scope-local-functions)) + ((functionp bare) (elisp-scope-report-s f 'function) (elisp-scope-n forms)) (t (elisp-scope-report-s f 'unknown) @@ -2850,7 +2847,7 @@ starting with a top-level form, by inspecting HEAD at each level: running Emacs session, analzye the form as a function call. - If HEAD is a safe macro (see `elisp-scope-safe-macro-p'), expand it - and analyzes the resulting form. + and analyze the resulting form. - If HEAD is unknown, then the arguments in TAIL are ignored, unless `elisp-scope-assume-func' is non-nil, in which case they are analyzed commit 177658f06846be91dbc487fc8f8fde7439610b58 Author: Eshel Yaron Date: Mon Oct 6 10:18:13 2025 +0200 ; elisp-scope.el: Drop special-form special handling * lisp/emacs-lisp/elisp-scope.el (elisp-scope-1): All special-forms should have an associated analyzer, so drop fallback handling for unknown special-forms. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 10c223b3a5e..8251e36fd88 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2594,6 +2594,10 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-special-form-analyzer quote (arg) (elisp-scope-quote arg elisp-scope-output-spec)) +(elisp-scope-define-special-form-analyzer interactive (&rest _) + ;; Out-of-place `interactive' call, do nothing. + ) + (elisp-scope-define-special-form-analyzer if (&optional test then &rest else) (elisp-scope-1 test) (elisp-scope-1 then elisp-scope-output-spec) @@ -2790,7 +2794,6 @@ are analyzed." ((setq this (or (alist-get bare elisp-scope-local-definitions) (function-get bare 'elisp-scope-analyzer))) (let ((elisp-scope-output-spec outspec)) (apply this form))) - ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) (cond ((elisp-scope-safe-macro-p bare) commit 81c5399012f7824186c0730a673998c2e09bab22 Author: Eshel Yaron Date: Mon Oct 6 11:00:03 2025 +0200 ; Test semantic highlighting with 'cl-macrolet' and 'cl-flet' diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 098bc231994..10c223b3a5e 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -733,6 +733,7 @@ Optional argument LOCAL is a local context to extend." (bare (bare-symbol func)) (len (length (symbol-name bare)))) (when beg + ;; TODO: Use a bespoke 'local-function-definition' role. (elisp-scope-report 'function beg len beg)) (if (cdr exps) ;; def is (FUNC ARGLIST BODY...) @@ -1540,6 +1541,7 @@ Optional argument LOCAL is a local context to extend." (when-let* ((bare (elisp-scope-sym-bare name)) (len (length (symbol-name bare)))) (let ((beg (elisp-scope-sym-pos name))) + ;; TODO: Use a bespoke 'local-macro-definition' role. (when beg (elisp-scope-report 'macro beg len beg)) (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) (elisp-scope-with-local-definition bare diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index 359a1f52c8a..d72e8d49fb4 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -97,3 +97,17 @@ (length long)))))) ;; ^ elisp-function-reference ;; ^ elisp-bound-variable + +(let ((foo 'bar)) +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-binding-variable + (cl-flet ((foo () 'baz)) +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ elisp-function-reference + (foo) +;; ^ elisp-function-reference + (cl-macrolet ((foo () 'foo)) +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ elisp-macro-call + (foo)))) +;; ^ elisp-macro-call commit ec7b376dd444d3cff733dcff21dc5fcb0dc56d61 Author: Eshel Yaron Date: Mon Oct 6 10:16:25 2025 +0200 elisp-scope.el: Unify and generalize local function/macro handling * lisp/emacs-lisp/elisp-scope.el (elisp-scope-local-definitions): New variable. Replaces... (elisp-scope-flet-alist, elisp-scope-macrolet-alist): these. Removed, no longer used. (elisp-scope-1, elisp-scope--handle-quoted): Update. (elisp-scope-with-local-definition): New macro. (elisp-scope-flet, elisp-scope-labels, elisp-scope-named-let) (elisp-scope-cl-macrolet): Use it. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 784c165645d..098bc231994 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -716,7 +716,13 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope-output-spec)) -(defvar elisp-scope-flet-alist nil) +(defvar elisp-scope-local-definitions nil) + +(defmacro elisp-scope-with-local-definition (sym def &rest body) + (declare (indent 2) (debug t)) + `(let ((elisp-scope-local-definitions + (cons (cons ,sym ,def) elisp-scope-local-definitions))) + ,@body)) (defun elisp-scope-flet (defs body outspec) (if defs @@ -724,16 +730,21 @@ Optional argument LOCAL is a local context to extend." (func (car def)) (exps (cdr def)) (beg (elisp-scope-sym-pos func)) - (bare (bare-symbol func))) + (bare (bare-symbol func)) + (len (length (symbol-name bare)))) (when beg - (elisp-scope-report 'function beg (length (symbol-name bare)) beg)) + (elisp-scope-report 'function beg len beg)) (if (cdr exps) ;; def is (FUNC ARGLIST BODY...) (elisp-scope-cl-lambda (car exps) (cdr exps)) ;; def is (FUNC EXP) (elisp-scope-1 (car exps))) - (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) - (elisp-scope-flet (cdr defs) body outspec))) + (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) + (elisp-scope-with-local-definition bare + (lambda (f &rest args) + (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) + (elisp-scope-n args)) + (elisp-scope-flet (cdr defs) body outspec)))) (elisp-scope-n body outspec))) (defun elisp-scope-labels (defs forms outspec) @@ -743,12 +754,17 @@ Optional argument LOCAL is a local context to extend." (args (cadr def)) (body (cddr def)) (beg (elisp-scope-sym-pos func)) - (bare (bare-symbol func))) + (bare (bare-symbol func)) + (len (length (symbol-name bare)))) (when beg - (elisp-scope-report 'function beg (length (symbol-name bare)) beg)) - (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) - (elisp-scope-lambda args body) - (elisp-scope-flet (cdr defs) forms outspec))) + (elisp-scope-report 'function beg len beg)) + (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) + (elisp-scope-with-local-definition bare + (lambda (f &rest args) + (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) + (elisp-scope-n args)) + (elisp-scope-lambda args body) + (elisp-scope-flet (cdr defs) forms outspec)))) (elisp-scope-n forms outspec))) (defvar elisp-scope-block-alist nil) @@ -777,7 +793,10 @@ Optional argument LOCAL is a local context to extend." ((or (symbol-with-pos-p arg) (symbolp arg)) (let ((bare (bare-symbol arg))) (cond - ((or (functionp bare) (memq bare elisp-scope-local-functions) (assq bare elisp-scope-flet-alist) elisp-scope-assume-func) + ((or (functionp bare) + (memq bare elisp-scope-local-functions) + (assq bare elisp-scope-local-definitions) + elisp-scope-assume-func) (elisp-scope-report-s arg 'function)) (t (elisp-scope-report-s arg 'unknown))))) ((consp arg) (elisp-scope-1 arg)))) @@ -1023,9 +1042,13 @@ Optional argument LOCAL is a local context to extend." (when-let* ((sym (car (ensure-list binding))) (bare (elisp-scope-sym-bare sym))) (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos sym) l)))) - (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist)) - (elisp-scope--local l)) - (elisp-scope-n body outspec))))) + (let ((pos (or beg (cons 'gen (incf elisp-scope-counter)))) + (len (length (symbol-name bare)))) + (elisp-scope-with-local-definition bare + (lambda (f &rest args) + (elisp-scope-report 'function (symbol-with-pos-pos f) len pos) + (elisp-scope-n args)) + (let ((elisp-scope--local l)) (elisp-scope-n body outspec))))))) (defun elisp-scope-rx (regexps) (dolist (regexp regexps) (elisp-scope-rx-1 regexp))) @@ -1508,19 +1531,21 @@ Optional argument LOCAL is a local context to extend." (more (elisp-scope-cl-lambda-1 (car more) (cdr more) body)) (t (elisp-scope-lambda nil body))))))) -(defvar elisp-scope-macrolet-alist nil) - (defun elisp-scope-cl-macrolet (bindings body outspec) (if-let* ((b (car bindings))) (let ((name (car b)) (arglist (cadr b)) (mbody (cddr b))) (elisp-scope-cl-lambda arglist mbody) - (when-let* ((bare (elisp-scope-sym-bare name))) - (when-let* ((beg (elisp-scope-sym-pos name))) - (elisp-scope-report 'macro beg (length (symbol-name bare)) beg)) - (let ((elisp-scope-macrolet-alist (elisp-scope-local-new bare (elisp-scope-sym-pos name) elisp-scope-macrolet-alist))) - (elisp-scope-cl-macrolet (cdr bindings) body outspec)))) + (when-let* ((bare (elisp-scope-sym-bare name)) + (len (length (symbol-name bare)))) + (let ((beg (elisp-scope-sym-pos name))) + (when beg (elisp-scope-report 'macro beg len beg)) + (let ((pos (or beg (cons 'gen (incf elisp-scope-counter))))) + (elisp-scope-with-local-definition bare + (lambda (f &rest _) + (elisp-scope-report 'macro (symbol-with-pos-pos f) len pos)) + (elisp-scope-cl-macrolet (cdr bindings) body outspec)))))) (elisp-scope-n body outspec))) (defun elisp-scope-define-minor-mode (mode _doc body) @@ -2592,9 +2617,8 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cl-defmethod elisp-scope--handle-quoted ((_spec (eql 'code)) arg) (let ((elisp-scope--local nil) (elisp-scope-current-let-alist-form nil) - (elisp-scope-flet-alist nil) + (elisp-scope-local-definitions nil) (elisp-scope-block-alist nil) - (elisp-scope-macrolet-alist nil) (elisp-scope-label-alist nil) (elisp-scope-rx-alist nil) (elisp-scope--quoted t)) @@ -2761,20 +2785,8 @@ are analyzed." (forms (cdr form)) (this nil)) (when bare (cond - ;; TODO: Collapse `elisp-scope-flet/macrolet/...-alist' into a - ;; unified "context", associating role+binder position to syms. - ((setq this (assq bare elisp-scope-flet-alist)) - (elisp-scope-report - 'function (symbol-with-pos-pos f) (length (symbol-name bare)) (cdr this)) - (elisp-scope-n forms)) - ((setq this (assq bare elisp-scope-macrolet-alist)) - (when (symbol-with-pos-p f) - (elisp-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 'elisp-scope-analyzer)) + ((setq this (or (alist-get bare elisp-scope-local-definitions) + (function-get bare 'elisp-scope-analyzer))) (let ((elisp-scope-output-spec outspec)) (apply this form))) ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) commit dfb10509a45caf90c0832983636292d021c582f6 Author: Eshel Yaron Date: Sun Oct 5 19:26:59 2025 +0200 ; elisp-scope.el: Thread output spec though more macro analyzers * lisp/emacs-lisp/elisp-scope.el (elisp-scope-flet) (elisp-scope-labels, elisp-scope-cl-macrolet): Add argument 'outspec' and pass it down to 'elisp-scope-n'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 13668a687c3..784c165645d 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -718,7 +718,7 @@ Optional argument LOCAL is a local context to extend." (defvar elisp-scope-flet-alist nil) -(defun elisp-scope-flet (defs body) +(defun elisp-scope-flet (defs body outspec) (if defs (let* ((def (car defs)) (func (car def)) @@ -733,10 +733,10 @@ Optional argument LOCAL is a local context to extend." ;; def is (FUNC EXP) (elisp-scope-1 (car exps))) (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) - (elisp-scope-flet (cdr defs) body))) - (elisp-scope-n body))) + (elisp-scope-flet (cdr defs) body outspec))) + (elisp-scope-n body outspec))) -(defun elisp-scope-labels (defs forms) +(defun elisp-scope-labels (defs forms outspec) (if defs (let* ((def (car defs)) (func (car def)) @@ -748,8 +748,8 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'function beg (length (symbol-name bare)) beg)) (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) (elisp-scope-lambda args body) - (elisp-scope-flet (cdr defs) forms))) - (elisp-scope-n forms))) + (elisp-scope-flet (cdr defs) forms outspec))) + (elisp-scope-n forms outspec))) (defvar elisp-scope-block-alist nil) @@ -1027,10 +1027,6 @@ Optional argument LOCAL is a local context to extend." (elisp-scope--local l)) (elisp-scope-n body outspec))))) -(defun elisp-scope-with-slots (spec-list object body) - (elisp-scope-1 object) - (elisp-scope-let spec-list body)) - (defun elisp-scope-rx (regexps) (dolist (regexp regexps) (elisp-scope-rx-1 regexp))) @@ -1514,7 +1510,7 @@ Optional argument LOCAL is a local context to extend." (defvar elisp-scope-macrolet-alist nil) -(defun elisp-scope-cl-macrolet (bindings body) +(defun elisp-scope-cl-macrolet (bindings body outspec) (if-let* ((b (car bindings))) (let ((name (car b)) (arglist (cadr b)) @@ -1524,8 +1520,8 @@ Optional argument LOCAL is a local context to extend." (when-let* ((beg (elisp-scope-sym-pos name))) (elisp-scope-report 'macro beg (length (symbol-name bare)) beg)) (let ((elisp-scope-macrolet-alist (elisp-scope-local-new bare (elisp-scope-sym-pos name) elisp-scope-macrolet-alist))) - (elisp-scope-cl-macrolet (cdr bindings) body)))) - (elisp-scope-n body))) + (elisp-scope-cl-macrolet (cdr bindings) body outspec)))) + (elisp-scope-n body outspec))) (defun elisp-scope-define-minor-mode (mode _doc body) (let ((explicit-var nil) (command t)) @@ -2281,13 +2277,14 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-named-let name bindings body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer cl-flet (bindings &rest body) - (elisp-scope-flet bindings body)) + (elisp-scope-flet bindings body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer cl-labels (bindings &rest body) - (elisp-scope-labels bindings body)) + (elisp-scope-labels bindings body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer with-slots (spec-list object &rest body) - (elisp-scope-with-slots spec-list object body)) + (elisp-scope-1 object) + (elisp-scope-let spec-list body)) (elisp-scope-define-macro-analyzer cl-defmethod (name &rest rest) (elisp-scope-defmethod name rest)) @@ -2357,7 +2354,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer cl-macrolet (bindings &rest body) ;; Unsafe macro! - (elisp-scope-cl-macrolet bindings body)) + (elisp-scope-cl-macrolet bindings body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer cl-symbol-macrolet (bindings &rest body) ;; Unsafe macro! commit 7fc85f8dec38e20a9ad32edf3ae1abd2cd79271b Author: Eshel Yaron Date: Sun Oct 5 17:36:07 2025 +0200 ; elisp-scope.el: Recognize special variable declarations * lisp/emacs-lisp/elisp-scope.el (special-variable-declaration): New symbol role. (defvar): Update analyzer to distinguish between declarations and definitions. (defconst): Add a separate analyzer. * lisp/progmodes/elisp-mode.el (elisp-special-variable-declaration): New face. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 20efdb1b6d1..13668a687c3 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -382,6 +382,13 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." :imenu "Variable" :namespace 'variable) +(elisp-scope-define-symbol-role special-variable-declaration () + :doc "Special variable declarations." + :definition 'defvar + :face 'elisp-special-variable-declaration + :help (cl-constantly "Special variable declaration") + :namespace 'variable) + (elisp-scope-define-symbol-role defface () :doc "Face definitions." :definition 'defface @@ -2529,13 +2536,17 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-special-form-analyzer setq (&rest args) (elisp-scope-setq args)) -(elisp-scope-define-special-form-analyzer defvar (&optional sym init _doc) +(elisp-scope-define-special-form-analyzer defvar (&rest args) + (elisp-scope-report-s + (car args) + (if (cdr args) 'defvar 'special-variable-declaration)) + (elisp-scope-1 (cadr args))) + +(elisp-scope-define-special-form-analyzer defconst (&optional sym init _doc) (elisp-scope-report-s sym 'defvar) (elisp-scope-1 init)) -(put 'defconst 'elisp-scope-analyzer #'elisp-scope--analyze-defvar) - -(defun elisp-scope-condition-case (var bodyform handlers) +(elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) (let* ((bare (bare-symbol var)) (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) (l (elisp-scope-local-new bare beg elisp-scope--local))) @@ -2553,12 +2564,6 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (let ((elisp-scope--local l)) (elisp-scope-n (cdr handler) elisp-scope-output-spec))))) -(elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) - (elisp-scope-condition-case var bodyform handlers)) - -(elisp-scope-define-macro-analyzer condition-case-unless-debug (var bodyform &rest handlers) - (elisp-scope-condition-case var bodyform handlers)) - (elisp-scope-define-special-form-analyzer function (&optional arg) (when arg (elisp-scope-sharpquote arg))) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index a768a0c39d6..94e3aff59c5 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -309,6 +309,9 @@ code analysis." (defface elisp-free-variable '((t :inherit underline)) "Face for highlighting free variables in Emacs Lisp code.") +(defface elisp-special-variable-declaration '((t :inherit elisp-free-variable)) + "Face for highlighting free variable declarations in Emacs Lisp code.") + (defface elisp-condition '((t :foreground "red")) "Face for highlighting `condition-case' conditions in Emacs Lisp code.") commit ef08bdcd6d4668746e20b184e324112118c58e03 Author: Eshel Yaron Date: Sat Oct 4 11:08:17 2025 +0200 ; Add another ELisp semantic highlighting test * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el: Add test with code that uses 'cl-loop'. diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el index d0cd23c6791..359a1f52c8a 100644 --- a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -29,3 +29,71 @@ ;; ^ elisp-function-reference 'success)) ;; ^ elisp-face + +(require 'cl-lib) +;; ^ (elisp-function-reference font-lock-keyword-face) +;; ^ (elisp-feature font-lock-constant-face) + +;; Taken from `completion-shorthand-try-completion' in minibuffer.el: +(defun foobaz (string table pred point) +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-defun font-lock-function-name-face) +;; ^ ^ ^ ^ elisp-binding-variable + (cl-loop with expanded +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ elisp-binding-variable + for (short . long) in +;; ^ elisp-binding-variable +;; ^ elisp-binding-variable + (with-current-buffer minibuffer--original-buffer +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ elisp-free-variable + read-symbol-shorthands) +;; ^ elisp-free-variable + for probe = +;; ^ elisp-binding-variable + (and (> point (length short)) +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + (string-prefix-p short string) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable +;; ^ elisp-bound-variable + (try-completion (setq expanded +;; ^ elisp-function-reference +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-bound-variable + (concat long +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + (substring +;; ^ elisp-function-reference + string +;; ^ elisp-bound-variable + (length short)))) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + table pred)) +;; ^ elisp-bound-variable +;; ^ elisp-bound-variable + when probe +;; ^ elisp-bound-variable + do (message "Shorthand expansion") +;; ^ elisp-function-reference + and return (cons expanded (max (length long) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable +;; ^ elisp-function-reference +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + (+ (- point (length short)) +;; ^ elisp-function-reference +;; ^ elisp-function-reference +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + (length long)))))) +;; ^ elisp-function-reference +;; ^ elisp-bound-variable commit edec0b8ec587d1988d745934f7296e9115827c11 Author: Eshel Yaron Date: Fri Oct 3 21:20:56 2025 +0200 ; Add a couple of tests for ELisp semantic highlighting * test/lisp/progmodes/elisp-mode-tests.el (elisp-test-font-lock): New test. * test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el: New resource file. diff --git a/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el new file mode 100644 index 00000000000..d0cd23c6791 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/semantic-highlighting.el @@ -0,0 +1,31 @@ +;;; semantic-highlighting.el --- -*- lexical-binding: t; -*- + +(defun foo (bar) +;; ^ (elisp-macro-call font-lock-keyword-face) +;; ^ (elisp-defun font-lock-function-name-face) +;; ^ elisp-binding-variable + (let ((cpa current-prefix-arg)) +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-binding-variable +;; ^ elisp-free-variable + (or cpa (ignore bar))) +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-bound-variable +;; ^ elisp-function-reference +;; ^ elisp-bound-variable + ) + +(add-face-text-property +;; ^ elisp-function-reference + (point) (mark) +;; ^ elisp-function-reference +;; ^ elisp-function-reference + (if not-good +;; ^ (elisp-special-form font-lock-keyword-face) +;; ^ elisp-free-variable + 'error +;; ^ elisp-face + (message "Good.") +;; ^ elisp-function-reference + 'success)) +;; ^ elisp-face diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 6b0535dafca..e7ae7bb79ba 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -1148,5 +1148,11 @@ evaluation of BODY." (insert "(a ,@)") (should-error (scan-sexps (+ (point-min) 3) 1)))) +(ert-deftest elisp-test-font-lock () + (let ((elisp-fontify-semantically t)) + (ert-font-lock-test-file + (ert-resource-file "semantic-highlighting.el") + 'emacs-lisp-mode))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here commit 3c645f3e62846e918a9e16034b84cc015f35a239 Author: Eshel Yaron Date: Fri Oct 3 21:19:20 2025 +0200 ; (elisp-scope-define-special-form-analyzer): Fix typo. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index f1c54b3eff3..20efdb1b6d1 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1672,7 +1672,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." `(progn (defun ,helper ,args ,@body) (elisp-scope-define-analyzer ,fsym (f &rest args) - (elisp-scope-report-s f 'macro) + (elisp-scope-report-s f 'special-form) (apply #',helper args))))) (defun elisp-scope--unquote (form) commit f8b8b9edc838c0de066cf545080698e271913a12 Author: Eshel Yaron Date: Fri Oct 3 19:49:15 2025 +0200 ; (elisp-scope-describe-symbol-role): Minor clean up. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 6fdae5e7d6c..f1c54b3eff3 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -82,7 +82,6 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." nil 'elisp-scope-read-symbol-role-history default)) (defvar describe-symbol-backends) -(defvar help-mode--current-data) ;;;###autoload (defun elisp-scope-add-symbol-roles-to-describe-symbol () @@ -122,9 +121,6 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." "mouse-2, RET: describe this symbol role") "'")))) parents ", "))) - (setq help-mode--current-data - (list :symbol role :type 'define-symbol-role - :file (find-lisp-object-file-name role 'define-symbol-role))) ;; Return the text we displayed for `describe-symbol-backends'. (buffer-string))))) commit f269531255f32397d29369c6690d19d456cd9408 Author: Eshel Yaron Date: Fri Oct 3 19:40:42 2025 +0200 ; elisp-scope.el: Support hooking into `describe-symbol-backends'. * lisp/emacs-lisp/elisp-scope.el (elisp-scope-add-symbol-roles-to-describe-symbol): New autoloaded function intended for user configs, hooks `elisp-scope-describe-symbol-role' into `describe-symbol'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 25ccfa65f3e..6fdae5e7d6c 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -81,10 +81,18 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." obarray #'elisp-scope-symbol-role-p 'confirm nil 'elisp-scope-read-symbol-role-history default)) +(defvar describe-symbol-backends) (defvar help-mode--current-data) ;;;###autoload -(defun elisp-scope-describe-symbol-role (role) +(defun elisp-scope-add-symbol-roles-to-describe-symbol () + (require 'help-mode) + (setf + (alist-get "symbol-role" describe-symbol-backends nil nil #'equal) + `(,#'elisp-scope-symbol-role-p ,#'elisp-scope-describe-symbol-role))) + +;;;###autoload +(defun elisp-scope-describe-symbol-role (role &rest _) (interactive (list (elisp-scope-read-symbol-role "Describe symbol role" (when-let* ((def (symbol-at-point)) @@ -116,7 +124,9 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." parents ", "))) (setq help-mode--current-data (list :symbol role :type 'define-symbol-role - :file (find-lisp-object-file-name role 'define-symbol-role))))))) + :file (find-lisp-object-file-name role 'define-symbol-role))) + ;; Return the text we displayed for `describe-symbol-backends'. + (buffer-string))))) (elisp-scope-define-symbol-role symbol-role () :doc "Symbol role names." commit efa5b730442749b8b3d9b02a00d095f38d09594e Author: Eshel Yaron Date: Fri Oct 3 19:14:34 2025 +0200 ; (elisp-scope-1): Add a "TODO". diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 2fc83899f35..25ccfa65f3e 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2753,6 +2753,8 @@ are analyzed." (forms (cdr form)) (this nil)) (when bare (cond + ;; TODO: Collapse `elisp-scope-flet/macrolet/...-alist' into a + ;; unified "context", associating role+binder position to syms. ((setq this (assq bare elisp-scope-flet-alist)) (elisp-scope-report 'function (symbol-with-pos-pos f) (length (symbol-name bare)) (cdr this)) commit 90e65c2abed3eff6ed517f7d30a6885023c14b40 Author: Eshel Yaron Date: Fri Oct 3 19:14:06 2025 +0200 ; (elisp-scope-gen-id-alist): Remove, unused. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 3a4f9c675dc..2fc83899f35 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -520,8 +520,6 @@ See `elisp-scope-1' for possible values.") (defvar elisp-scope-current-let-alist-form nil) -(defvar elisp-scope-gen-id-alist nil) - (defsubst elisp-scope-local-new (sym pos &optional local) "Return new local context with SYM bound at POS. commit c412bd83ff582694621918289547e4e33a033fb1 Author: Eshel Yaron Date: Fri Oct 3 19:09:05 2025 +0200 ; elisp-scope.el: Fix 'custom-declare-face' analyzer. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index d071721abf4..3a4f9c675dc 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1871,8 +1871,9 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-function-analyzer custom-declare-face (face spec doc &rest args) (elisp-scope-1 face '(symbol . defface)) ;; TODO: Use `elisp-scope-1' with an appropriate outspec. - (when-let* ((q (elisp-scope--unquote spec))) - (when (consp q) (dolist (s q) (elisp-scope-face (cdr s))))) + (if-let* ((q (elisp-scope--unquote spec))) + (when (consp q) (dolist (s q) (elisp-scope-face (cdr s)))) + (elisp-scope-1 spec)) (elisp-scope-1 doc) (while-let ((kw (car-safe args)) (bkw (elisp-scope-sym-bare kw)) commit 320df8ad358eecefd6ff40ba0eab171f8de6f9d7 Author: Eshel Yaron Date: Fri Oct 3 18:36:08 2025 +0200 ; elisp-scope.el: Improve 'oclosure-define' 'slots' analysis diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 22c3e82dab4..d071721abf4 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1708,7 +1708,11 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 name '(symbol . defoclosure)) (elisp-scope-1 docstring) (elisp-scope-1 parent-names '(repeat . (symbol . oclosure))) - (elisp-scope-1 slots) ;TODO: Specify spec of `slots'. + (elisp-scope-1 slots + '(repeat . + (or (symbol . slot) + (cons (symbol . slot) . + (plist (:type . cl-type)))))) (while-let ((kw (car-safe props)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) commit bde38ef4800c4d6c287bae869fc66c5d32711530 Author: Eshel Yaron Date: Fri Oct 3 18:11:35 2025 +0200 ; Rename 'elisp-scope-output-type' to 'elisp-scope-output-spec'. * lisp/emacs-lisp/elisp-scope.el: Change all references to this notion of "type" to say "spec" instead. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 1915609c8df..22c3e82dab4 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -512,8 +512,8 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (defvar elisp-scope--local nil) -(defvar elisp-scope-output-type nil - "Output type of the form currently analyzed, or nil if unknown. +(defvar elisp-scope-output-spec nil + "Output spec of the form currently analyzed, or nil if unknown. See `elisp-scope-1' for possible values.") (defvar elisp-scope-callback #'ignore) @@ -586,7 +586,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-let-1 (if bare (elisp-scope-local-new bare beg local) local) (cdr bindings) body)) (let ((elisp-scope--local local)) - (elisp-scope-n body elisp-scope-output-type)))) + (elisp-scope-n body elisp-scope-output-spec)))) (defun elisp-scope-let (bindings body) (elisp-scope-let-1 elisp-scope--local bindings body)) @@ -602,7 +602,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-1 (cadr binding)) (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) (elisp-scope-let* (cdr bindings) body))) - (elisp-scope-n body elisp-scope-output-type))) + (elisp-scope-n body elisp-scope-output-spec))) (defun elisp-scope-interactive (intr spec modes) (when (symbol-with-pos-p intr) @@ -612,7 +612,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-1 spec) (mapc #'elisp-scope-major-mode-name modes)) -(defun elisp-scope-lambda (args body &optional outtype) +(defun elisp-scope-lambda (args body &optional outspec) (let ((l elisp-scope--local)) (when (listp args) (dolist (arg args) @@ -688,7 +688,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-report 'ampersand beg len) (elisp-scope-report 'binding-variable beg len beg))))))) ;; Handle BODY. - (let ((elisp-scope--local l)) (elisp-scope-n body outtype)))) + (let ((elisp-scope--local l)) (elisp-scope-n body outspec)))) (defun elisp-scope-defun (name args body) (when-let* ((beg (elisp-scope-sym-pos name)) @@ -703,7 +703,7 @@ Optional argument LOCAL is a local context to extend." beg (length (symbol-name bare)))) (elisp-scope-lambda args body)) -(defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope-output-type)) +(defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope-output-spec)) (defvar elisp-scope-flet-alist nil) @@ -996,7 +996,7 @@ Optional argument LOCAL is a local context to extend." ((memq bare '(end)) (elisp-scope-loop-end rest)) ((memq bare '(and else)) (elisp-scope-loop-and rest)))))) -(defun elisp-scope-named-let (name bindings body &optional outtype) +(defun elisp-scope-named-let (name bindings body &optional outspec) (let ((bare (elisp-scope-sym-bare name)) (beg (elisp-scope-sym-pos name))) (when beg @@ -1014,7 +1014,7 @@ Optional argument LOCAL is a local context to extend." (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos sym) l)))) (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist)) (elisp-scope--local l)) - (elisp-scope-n body outtype))))) + (elisp-scope-n body outspec))))) (defun elisp-scope-with-slots (spec-list object body) (elisp-scope-1 object) @@ -1684,11 +1684,11 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-analyzer eval (f form &optional lexical) (elisp-scope-report-s f 'function) - ;; TODO: Use elisp-scope-1 with outtype `code' in the next line. + ;; TODO: Use elisp-scope-1 with outspec `code' in the next line. ;; Difficulty: that would analyze the quoted code as if it is ;; evaluated in an unrelated local environment, so local variables ;; wouldn't be recognized correctly etc. We can solve that by adding - ;; some `code-evaled-here' outtype. + ;; some `code-evaled-here' outspec. (elisp-scope-1 (or (elisp-scope--unquote form) form)) (elisp-scope-1 lexical)) @@ -1708,7 +1708,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 name '(symbol . defoclosure)) (elisp-scope-1 docstring) (elisp-scope-1 parent-names '(repeat . (symbol . oclosure))) - (elisp-scope-1 slots) ;TODO: Specify type of `slots'. + (elisp-scope-1 slots) ;TODO: Specify spec of `slots'. (while-let ((kw (car-safe props)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) @@ -1842,7 +1842,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-report-s kw 'constant) (cl-case bkw (:type - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (if-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-widget-type-1 quoted) (elisp-scope-1 (cadr args)))) @@ -1866,7 +1866,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-function-analyzer custom-declare-face (face spec doc &rest args) (elisp-scope-1 face '(symbol . defface)) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (when-let* ((q (elisp-scope--unquote spec))) (when (consp q) (dolist (s q) (elisp-scope-face (cdr s))))) (elisp-scope-1 doc) @@ -1915,7 +1915,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (if-let* ((q (elisp-scope--unquote prop)) ((eq (elisp-scope-sym-bare q) 'face)) (face (elisp-scope--unquote val))) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (elisp-scope-face face) (elisp-scope-1 val))) @@ -1982,7 +1982,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (if-let* (((memq (elisp-scope-sym-bare (elisp-scope--unquote prop)) '(mouse-face face))) (q (elisp-scope--unquote val))) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (elisp-scope-face q) (elisp-scope-1 val)) (elisp-scope-1 obj)) @@ -1996,7 +1996,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cl-case (elisp-scope-sym-bare (elisp-scope--unquote (car props))) ((face mouse-face) (if-let* ((q (elisp-scope--unquote (cadr props)))) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (elisp-scope-face q) (elisp-scope-1 (cadr props)))) (otherwise (elisp-scope-1 (cadr props)))) @@ -2103,22 +2103,22 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 mode '(symbol . major-mode)) (elisp-scope-1 parent '(symbol . major-mode))) -(elisp-scope-define-function-analyzer elisp-scope-report (type &rest args) - (elisp-scope-1 type '(symbol . symbol-role)) +(elisp-scope-define-function-analyzer elisp-scope-report (role &rest args) + (elisp-scope-1 role '(symbol . symbol-role)) (mapc #'elisp-scope-1 args)) -(elisp-scope-define-function-analyzer elisp-scope-report-s (&optional sym type) +(elisp-scope-define-function-analyzer elisp-scope-report-s (&optional sym role) (elisp-scope-1 sym) - (elisp-scope-1 type '(symbol . symbol-role))) + (elisp-scope-1 role '(symbol . symbol-role))) -(elisp-scope-define-function-analyzer elisp-scope-1 (&optional form outtype) +(elisp-scope-define-function-analyzer elisp-scope-1 (&optional form outspec) (elisp-scope-1 form) - (elisp-scope-1 outtype 'type)) + (elisp-scope-1 outspec 'spec)) (elisp-scope-define-function-analyzer icons--register (&optional name parent spec doc kws) (elisp-scope-1 name '(symbol . deficon)) (elisp-scope-1 parent '(symbol . icon)) - (elisp-scope-1 spec) ;TODO: Specify type of `spec'. + (elisp-scope-1 spec) ;TODO: Specify spec of `spec'. (elisp-scope-1 doc) (if-let* ((q (elisp-scope--unquote kws))) (progn @@ -2133,7 +2133,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-function-analyzer setopt--set (&optional var val) (elisp-scope-1 var '(symbol . free-variable)) - (elisp-scope-1 val elisp-scope-output-type)) + (elisp-scope-1 val elisp-scope-output-spec)) (elisp-scope-define-function-analyzer autoload (&optional func file doc int type) (elisp-scope-1 func '(symbol . function)) @@ -2182,7 +2182,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 maps) (elisp-scope-1 doc) (if-let* ((q (elisp-scope--unquote menu))) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (elisp-scope--easy-menu-do-define-menu q) (elisp-scope-1 menu))) @@ -2190,7 +2190,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 keymap) (elisp-scope-1 key) (if-let* ((q (elisp-scope--unquote def))) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + ;; TODO: Use `elisp-scope-1' with an appropriate outspec. (cond ((eq (elisp-scope-sym-bare (car-safe q)) 'menu-item) (let ((fn (caddr q)) (it (cdddr q))) @@ -2262,7 +2262,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-loop clauses)) (elisp-scope-define-macro-analyzer named-let (name bindings &rest body) - (elisp-scope-named-let name bindings body elisp-scope-output-type)) + (elisp-scope-named-let name bindings body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer cl-flet (bindings &rest body) (elisp-scope-flet bindings body)) @@ -2415,7 +2415,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (setq l (elisp-scope-local-new bare beg l))) (elisp-scope-1 place)) (elisp-scope-1 (cadr binding)))) - (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope-output-type)))) + (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope-output-spec)))) (elisp-scope-define-macro-analyzer setf (&rest args) (elisp-scope-setq args)) @@ -2427,7 +2427,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer with-memoization (&optional place &rest body) (elisp-scope-1 place) - (elisp-scope-n body elisp-scope-output-type)) + (elisp-scope-n body elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer cl-pushnew (&rest args) (mapc #'elisp-scope-1 args)) @@ -2437,17 +2437,17 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer static-if (&optional test then &rest else) (elisp-scope-1 test) - (elisp-scope-1 then elisp-scope-output-type) - (elisp-scope-n else elisp-scope-output-type)) + (elisp-scope-1 then elisp-scope-output-spec) + (elisp-scope-n else elisp-scope-output-spec)) (elisp-scope-define-macro-analyzer static-when (&optional test &rest body) (elisp-scope-1 test) - (elisp-scope-n body elisp-scope-output-type)) + (elisp-scope-n body elisp-scope-output-spec)) (put 'static-unless 'elisp-scope-analyzer #'elisp-scope--analyze-static-when) (elisp-scope-define-macro-analyzer eval-when-compile (&rest body) - (elisp-scope-n body elisp-scope-output-type)) + (elisp-scope-n body elisp-scope-output-spec)) (put 'eval-and-compile 'elisp-scope-analyzer #'elisp-scope--analyze-eval-when-compile) @@ -2484,24 +2484,24 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 when)) (elisp-scope-define-macro-analyzer backquote (&optional structure) - (elisp-scope-backquote structure elisp-scope-output-type)) + (elisp-scope-backquote structure elisp-scope-output-spec)) (defvar elisp-scope-backquote-depth 0) -(defun elisp-scope-backquote (structure &optional outtype) +(defun elisp-scope-backquote (structure &optional outspec) (let ((elisp-scope-backquote-depth (1+ elisp-scope-backquote-depth))) - (elisp-scope-backquote-1 structure outtype))) + (elisp-scope-backquote-1 structure outspec))) -(defun elisp-scope-backquote-1 (structure &optional outtype) +(defun elisp-scope-backquote-1 (structure &optional outspec) (cond ((vectorp structure) (dotimes (i (length structure)) (elisp-scope-backquote-1 (aref structure i)))) - ((atom structure) (elisp-scope-quote structure outtype)) + ((atom structure) (elisp-scope-quote structure outspec)) ((or (eq (car structure) backquote-unquote-symbol) (eq (car structure) backquote-splice-symbol)) (if (= elisp-scope-backquote-depth 1) - (elisp-scope-1 (cadr structure) outtype) + (elisp-scope-1 (cadr structure) outspec) (let ((elisp-scope-backquote-depth (1- elisp-scope-backquote-depth))) (elisp-scope-backquote-1 (cadr structure))))) (t @@ -2515,7 +2515,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-let* bindings body)) (elisp-scope-define-special-form-analyzer cond (&rest clauses) - (dolist (clause clauses) (elisp-scope-n clause elisp-scope-output-type))) + (dolist (clause clauses) (elisp-scope-n clause elisp-scope-output-spec))) (elisp-scope-define-special-form-analyzer setq (&rest args) (elisp-scope-setq args)) @@ -2531,7 +2531,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) (l (elisp-scope-local-new bare beg elisp-scope--local))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) - (elisp-scope-1 bodyform elisp-scope-output-type) + (elisp-scope-1 bodyform elisp-scope-output-spec) (dolist (handler handlers) (dolist (cond-name (ensure-list (car-safe handler))) (when-let* ((cbeg (elisp-scope-sym-pos cond-name)) @@ -2542,7 +2542,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." ((keywordp cbare) (elisp-scope-report 'constant cbeg clen)) (t (elisp-scope-report 'condition cbeg clen))))) (let ((elisp-scope--local l)) - (elisp-scope-n (cdr handler) elisp-scope-output-type))))) + (elisp-scope-n (cdr handler) elisp-scope-output-spec))))) (elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) (elisp-scope-condition-case var bodyform handlers)) @@ -2554,31 +2554,31 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (when arg (elisp-scope-sharpquote arg))) (elisp-scope-define-special-form-analyzer quote (arg) - (elisp-scope-quote arg elisp-scope-output-type)) + (elisp-scope-quote arg elisp-scope-output-spec)) (elisp-scope-define-special-form-analyzer if (&optional test then &rest else) (elisp-scope-1 test) - (elisp-scope-1 then elisp-scope-output-type) - (elisp-scope-n else elisp-scope-output-type)) + (elisp-scope-1 then elisp-scope-output-spec) + (elisp-scope-n else elisp-scope-output-spec)) (elisp-scope-define-special-form-analyzer and (&rest forms) - (elisp-scope-n forms elisp-scope-output-type)) + (elisp-scope-n forms elisp-scope-output-spec)) (elisp-scope-define-special-form-analyzer or (&rest forms) - (dolist (form forms) (elisp-scope-1 form elisp-scope-output-type))) + (dolist (form forms) (elisp-scope-1 form elisp-scope-output-spec))) -(defun elisp-scope-quote (arg &optional outtype) - (when outtype - (when-let* ((type (elisp-scope--match-type-to-arg outtype arg))) - (elisp-scope--handle-quoted type arg)))) +(defun elisp-scope-quote (arg &optional outspec) + (when outspec + (when-let* ((spec (elisp-scope--match-spec-to-arg outspec arg))) + (elisp-scope--handle-quoted spec arg)))) -(cl-defgeneric elisp-scope--handle-quoted (type arg)) +(cl-defgeneric elisp-scope--handle-quoted (spec arg)) -(cl-defmethod elisp-scope--handle-quoted ((_type (eql t)) _arg) +(cl-defmethod elisp-scope--handle-quoted ((_spec (eql t)) _arg) ;; Do nothing. ) -(cl-defmethod elisp-scope--handle-quoted ((_type (eql 'code)) arg) +(cl-defmethod elisp-scope--handle-quoted ((_spec (eql 'code)) arg) (let ((elisp-scope--local nil) (elisp-scope-current-let-alist-form nil) (elisp-scope-flet-alist nil) @@ -2589,37 +2589,37 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope--quoted t)) (elisp-scope-1 arg))) -(cl-defmethod elisp-scope--handle-quoted ((type (head symbol)) arg) - (when-let* ((role (cdr type))) (elisp-scope-report-s arg role))) +(cl-defmethod elisp-scope--handle-quoted ((spec (head symbol)) arg) + (when-let* ((role (cdr spec))) (elisp-scope-report-s arg role))) -(cl-defmethod elisp-scope--handle-quoted ((type (head list)) arg) - (let ((types (cdr type))) - (while types (elisp-scope--handle-quoted (pop types) (pop arg))))) +(cl-defmethod elisp-scope--handle-quoted ((spec (head list)) arg) + (let ((specs (cdr spec))) + (while specs (elisp-scope--handle-quoted (pop specs) (pop arg))))) -(cl-defmethod elisp-scope--handle-quoted ((type (head cons)) arg) - (elisp-scope--handle-quoted (cadr type) (car arg)) - (elisp-scope--handle-quoted (cddr type) (cdr arg))) +(cl-defmethod elisp-scope--handle-quoted ((spec (head cons)) arg) + (elisp-scope--handle-quoted (cadr spec) (car arg)) + (elisp-scope--handle-quoted (cddr spec) (cdr arg))) -(cl-defgeneric elisp-scope--match-type-to-arg (type arg)) +(cl-defgeneric elisp-scope--match-spec-to-arg (spec arg)) -(cl-defmethod elisp-scope--match-type-to-arg ((type (eql t)) _arg) type) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (eql t)) _arg) spec) -(cl-defmethod elisp-scope--match-type-to-arg ((type (eql 'code)) _arg) type) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (eql 'code)) _arg) spec) -(cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'type)) arg) - (elisp-scope--match-type-to-arg - ;; Unfold `type'. +(cl-defmethod elisp-scope--match-spec-to-arg ((_spec (eql 'spec)) arg) + (elisp-scope--match-spec-to-arg + ;; Unfold `spec'. '(or (symbol) (cons (member symbol) . (symbol . symbol-role)) - (cons (member repeat) . type) - (cons (member or) . (repeat . type)) - (cons (member cons) . (cons type . type)) + (cons (member repeat) . spec) + (cons (member or) . (repeat . spec)) + (cons (member cons) . (cons spec . spec)) (cons (member member) . t) - (cons (member plist) . (repeat . (cons (symbol . constant) . type)))) + (cons (member plist) . (repeat . (cons (symbol . constant) . spec)))) arg)) -(cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'cl-type)) arg) - (elisp-scope--match-type-to-arg +(cl-defmethod elisp-scope--match-spec-to-arg ((_spec (eql 'cl-type)) arg) + (elisp-scope--match-spec-to-arg ;; Unfold `cl-type'. '(or (member t) (symbol . type) @@ -2629,35 +2629,35 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cons (member satisfies) . (cons (or (symbol . function) code) . t))) arg)) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head symbol)) arg) - (when (or (symbolp arg) (symbol-with-pos-p arg)) type)) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head symbol)) arg) + (when (or (symbolp arg) (symbol-with-pos-p arg)) spec)) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head repeat)) arg) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head repeat)) arg) (when (listp arg) (named-let loop ((args arg) (acc nil)) (if args - (when-let* ((res (elisp-scope--match-type-to-arg (cdr type) (car args)))) + (when-let* ((res (elisp-scope--match-spec-to-arg (cdr spec) (car args)))) (loop (cdr args) (cons res acc))) (cons 'list (nreverse acc)))))) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head or)) arg) - (named-let loop ((types (cdr type))) - (when types - (if-let* ((res (elisp-scope--match-type-to-arg (car types) arg))) res - (loop (cdr types)))))) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head or)) arg) + (named-let loop ((specs (cdr spec))) + (when specs + (if-let* ((res (elisp-scope--match-spec-to-arg (car specs) arg))) res + (loop (cdr specs)))))) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head cons)) arg) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head cons)) arg) (when (consp arg) - (let ((car-type (cadr type)) - (cdr-type (cddr type))) - (when-let* ((car-res (elisp-scope--match-type-to-arg car-type (car arg))) - (cdr-res (elisp-scope--match-type-to-arg cdr-type (cdr arg)))) + (let ((car-spec (cadr spec)) + (cdr-spec (cddr spec))) + (when-let* ((car-res (elisp-scope--match-spec-to-arg car-spec (car arg))) + (cdr-res (elisp-scope--match-spec-to-arg cdr-spec (cdr arg)))) (cons 'cons (cons car-res cdr-res)))))) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head member)) arg) - (let ((symbols-with-pos-enabled t)) (and (member arg (cdr type)) t))) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head member)) arg) + (let ((symbols-with-pos-enabled t)) (and (member arg (cdr spec)) t))) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head plist)) arg) +(cl-defmethod elisp-scope--match-spec-to-arg ((spec (head plist)) arg) (cond ((consp arg) (let ((res nil) (go t)) @@ -2666,17 +2666,17 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (bkw (elisp-scope-sym-bare key)) (val (cadr arg))) (push (if (keywordp bkw) '(symbol . constant) t) res) - (push (setq go (elisp-scope--match-type-to-arg (alist-get bkw (cdr type) t) val)) res)) + (push (setq go (elisp-scope--match-spec-to-arg (alist-get bkw (cdr spec) t) val)) res)) (setq arg (cddr arg))) (when go (cons 'list (nreverse res))))) ((null arg) t))) (elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) (elisp-scope-1 tag '(symbol . throw-tag)) - (elisp-scope-n body elisp-scope-output-type)) + (elisp-scope-n body elisp-scope-output-spec)) (elisp-scope-define-special-form-analyzer progn (&rest body) - (elisp-scope-n body elisp-scope-output-type)) + (elisp-scope-n body elisp-scope-output-spec)) (put 'inline 'elisp-scope-analyzer #'elisp-scope--analyze-progn) (put 'save-current-buffer 'elisp-scope-analyzer #'elisp-scope--analyze-progn) @@ -2687,7 +2687,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (mapc #'elisp-scope-1 rest)) (elisp-scope-define-special-form-analyzer prog1 (&rest body) - (when (consp body) (elisp-scope-1 (pop body) elisp-scope-output-type)) + (when (consp body) (elisp-scope-1 (pop body) elisp-scope-output-spec)) (elisp-scope-n body)) (put 'unwind-protect 'elisp-scope-analyzer #'elisp-scope--analyze-prog1) @@ -2701,15 +2701,15 @@ If SYM is not a symbol with position information, do nothing." (defvar-local elisp-scope-buffer-file-name nil) -(defun elisp-scope-1 (form &optional outtype) - "Analyze FORM as an evaluated form with expected output type OUTTYPE. +(defun elisp-scope-1 (form &optional outspec) + "Analyze FORM as an evaluated form with expected output spec OUTSPEC. -If OUTTYPE is non-nil, it specifies FORM's expected \"output type\". +If OUTSPEC is non-nil, it specifies FORM's expected \"output spec\". This guides the analysis of quoted (sub)forms. -OUTTYPE can be one the following: +OUTSPEC can be one the following: - t: FORM evaluates to an arbitrary object. - In other words, OUTTYPE of t conveys no information about FORM. + In other words, OUTSPEC of t conveys no information about FORM. - `code': FORM evaluates to a form to be evaluated elsewhere. The quoted output of FORM will again be analyzed as an evaluated form, @@ -2719,22 +2719,22 @@ OUTTYPE can be one the following: See `elisp-scope-define-symbol-role' for more information about defining new symbol roles. -- (repeat . TYPE): FORM evaluates to a list with elements of type TYPE. +- (repeat . SPEC): FORM evaluates to a list with elements of spec SPEC. -- (cons CARTYPE . CDRTYPE): FORM evaluates to a cons cell whose `car' - has type CARTYPE and whose `cdr' has type CDRTYPE. +- (cons CARSPEC . CDRSPEC): FORM evaluates to a cons cell whose `car' + has spec CARSPEC and whose `cdr' has spec CDRSPEC. - (member . VALS): FORM evaluates to a `member' of VALS. -- (plist . VALTYPES): FORM evaluates to a plist. VALTYPES is an alist - associating value types to properties in the plist. For example, an - entry (:face . (symbol . face)) in VALTYPES says that the value of the +- (plist . VALSPECS): FORM evaluates to a plist. VALSPECS is an alist + associating value specs to properties in the plist. For example, an + entry (:face . (symbol . face)) in VALSPECS says that the value of the property `:face' in the plist is a face name. -- (or . TYPES): FORM evaluates to a value that matches one of TYPES. +- (or . SPECS): FORM evaluates to a value that matches one of SPECS. For example, to analyze a FORM that evaluates to either a list of major -mode names or just to a single major mode name, use OUTTYPE as follows: +mode names or just to a single major mode name, use OUTSPEC as follows: (elisp-scope-1 FORM \\='(or (repeat . (symbol . major-mode)) (symbol . major-mode))) @@ -2762,7 +2762,7 @@ are analyzed." ;; Hence we cannot interpret their arguments. ) ((setq this (function-get bare 'elisp-scope-analyzer)) - (let ((elisp-scope-output-type outtype)) (apply this form))) + (let ((elisp-scope-output-spec outspec)) (apply this form))) ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) (cond @@ -2775,7 +2775,7 @@ are analyzed." (macroexpand-all-environment (append (mapcar #'list elisp-scope-unsafe-macros) macroexpand-all-environment)) (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) - (elisp-scope-1 expanded outtype))) + (elisp-scope-1 expanded outspec))) ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)))) ((or (functionp bare) (memq bare elisp-scope-local-functions)) (elisp-scope-report-s f 'function) (elisp-scope-n forms)) @@ -2784,13 +2784,13 @@ are analyzed." (when elisp-scope-assume-func (elisp-scope-n forms))))))) ((symbol-with-pos-p form) (elisp-scope-s form)))) -(defun elisp-scope-n (forms &optional outtype) +(defun elisp-scope-n (forms &optional outspec) "Analyze FORMS as evaluated forms. -OUTTYPE is the expected output type of the last form in FORMS, if any. +OUTSPEC is the expected output spec of the last form in FORMS, if any. It is passed to `elisp-scope-1', which see." (while (cdr-safe forms) (elisp-scope-1 (pop forms))) - (when-let* ((form (car-safe forms))) (elisp-scope-1 form outtype))) + (when-let* ((form (car-safe forms))) (elisp-scope-1 form outspec))) ;;;###autoload (defun elisp-scope-analyze-form (callback &optional stream) @@ -2829,13 +2829,13 @@ starting with a top-level form, by inspecting HEAD at each level: An analyzer (function specified via the `elisp-scope-analyzer' property) can use the functions `elisp-scope-report-s', `elisp-scope-1' and `elisp-scope-n' to analyze its arguments, and it can consult the -variable `elisp-scope-output-type' to obtain the expected output type of +variable `elisp-scope-output-spec' to obtain the expected output spec of the analyzed form. For example, the following is a suitable analyzer for the `identity' function: (lambda (fsym arg) (elisp-scope-report-s fsym \\='function) - (elisp-scope-1 arg elisp-scope-output-type))" + (elisp-scope-1 arg elisp-scope-output-spec))" (let ((elisp-scope-counter 0) (elisp-scope-callback callback) (read-symbol-shorthands nil) commit 22327f58bbfa2d34b3160248ce3bfd1969ef7d0d Author: Eshel Yaron Date: Fri Oct 3 18:00:54 2025 +0200 ; elisp-scope.el: Improve 'defclass' slots analysis. Extend the "type" system (to be renamed to "spec" in subsequent commit) of elisp-scope.el with a plist spec. This allows us to define a spec for the 'slots' argument of 'eieio-defclass-internal'. Also add a 'cl-type' spec, describing the type specifications used by 'cl-typep', and replace the 'equal' spec with a more general 'member' spec, like we have in 'cl-typep'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 6bea0816927..1915609c8df 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1878,23 +1878,9 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (setq args (cddr args))) (when args (elisp-scope-n args))) -(defun elisp-scope-typep (type) - (cond - ((or (symbolp type) (symbol-with-pos-p type)) - (unless (booleanp (elisp-scope-sym-bare type)) - (elisp-scope-report-s type 'type))) - ((consp type) - (cond - ((memq (elisp-scope-sym-bare (car type)) '(and or not)) - (mapc #'elisp-scope-typep (cdr type))) - ((eq (elisp-scope-sym-bare (car type)) 'satisfies) - (elisp-scope-report-s (cadr type) 'function)))))) - (elisp-scope-define-function-analyzer cl-typep (val type) (elisp-scope-1 val) - ;; TODO: Use `elisp-scope-1' with an appropriate outtype. - (when-let* ((q (elisp-scope--unquote type))) - (elisp-scope-typep q))) + (elisp-scope-1 type 'cl-type)) (elisp-scope-define-function-analyzer pulse-momentary-highlight-region (start end &optional face) (elisp-scope-1 start) @@ -2021,7 +2007,20 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (&optional name superclasses slots options) (elisp-scope-1 name '(symbol . deftype)) (elisp-scope-1 superclasses '(repeat . (symbol . type))) - (elisp-scope-1 slots) ;TODO: Specify type of `slots'. + (elisp-scope-1 slots + '(repeat + cons + (symbol . slot) + plist + (:initform . code) + (:initarg . (symbol . constant)) + (:accessor . (symbol . defun)) + (:allocation . code) + (:writer . (symbol . function)) + (:reader . (symbol . function)) + (:type . cl-type) + ;; TODO: add (:custom . custom-type) + )) (elisp-scope-1 options)) (elisp-scope-define-function-analyzer cl-struct-define @@ -2591,7 +2590,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 arg))) (cl-defmethod elisp-scope--handle-quoted ((type (head symbol)) arg) - (elisp-scope-report-s arg (cdr type))) + (when-let* ((role (cdr type))) (elisp-scope-report-s arg role))) (cl-defmethod elisp-scope--handle-quoted ((type (head list)) arg) (let ((types (cdr type))) @@ -2610,14 +2609,24 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'type)) arg) (elisp-scope--match-type-to-arg ;; Unfold `type'. - '(or (equal . t) - (equal . code) - (equal . type) - (cons (equal . symbol) . (symbol . symbol-role)) - (cons (equal . repeat) . type) - (cons (equal . or) . (repeat . type)) - (cons (equal . cons) . (cons type . type)) - (cons (equal . equal) . t)) + '(or (symbol) + (cons (member symbol) . (symbol . symbol-role)) + (cons (member repeat) . type) + (cons (member or) . (repeat . type)) + (cons (member cons) . (cons type . type)) + (cons (member member) . t) + (cons (member plist) . (repeat . (cons (symbol . constant) . type)))) + arg)) + +(cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'cl-type)) arg) + (elisp-scope--match-type-to-arg + ;; Unfold `cl-type'. + '(or (member t) + (symbol . type) + (cons (member integer float real number) . t) + (cons (member or and not) . (repeat . cl-type)) + (cons (member member cl-member) . (repeat . t)) + (cons (member satisfies) . (cons (or (symbol . function) code) . t))) arg)) (cl-defmethod elisp-scope--match-type-to-arg ((type (head symbol)) arg) @@ -2645,8 +2654,22 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (cdr-res (elisp-scope--match-type-to-arg cdr-type (cdr arg)))) (cons 'cons (cons car-res cdr-res)))))) -(cl-defmethod elisp-scope--match-type-to-arg ((type (head equal)) arg) - (let ((symbols-with-pos-enabled t)) (equal (cdr type) arg))) +(cl-defmethod elisp-scope--match-type-to-arg ((type (head member)) arg) + (let ((symbols-with-pos-enabled t)) (and (member arg (cdr type)) t))) + +(cl-defmethod elisp-scope--match-type-to-arg ((type (head plist)) arg) + (cond + ((consp arg) + (let ((res nil) (go t)) + (while (and arg go) + (let* ((key (car arg)) + (bkw (elisp-scope-sym-bare key)) + (val (cadr arg))) + (push (if (keywordp bkw) '(symbol . constant) t) res) + (push (setq go (elisp-scope--match-type-to-arg (alist-get bkw (cdr type) t) val)) res)) + (setq arg (cddr arg))) + (when go (cons 'list (nreverse res))))) + ((null arg) t))) (elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) (elisp-scope-1 tag '(symbol . throw-tag)) @@ -2701,7 +2724,12 @@ OUTTYPE can be one the following: - (cons CARTYPE . CDRTYPE): FORM evaluates to a cons cell whose `car' has type CARTYPE and whose `cdr' has type CDRTYPE. -- (equal . VAL): FORM evaluates to VAL (or something `equal' to VAL). +- (member . VALS): FORM evaluates to a `member' of VALS. + +- (plist . VALTYPES): FORM evaluates to a plist. VALTYPES is an alist + associating value types to properties in the plist. For example, an + entry (:face . (symbol . face)) in VALTYPES says that the value of the + property `:face' in the plist is a face name. - (or . TYPES): FORM evaluates to a value that matches one of TYPES. commit 5339cf0010752b9695e5f6a848d87aeaea4c549f Author: Eshel Yaron Date: Thu Oct 2 16:33:27 2025 +0200 ; Rename 'elisp-scope--output-type' to make it public * lisp/emacs-lisp/elisp-scope.el (elisp-scope--output-type): Add docstring and rename to... (elisp-scope-output-type): this. Update all references. * lisp/emacs-lisp/elisp-scope.el (elisp-scope-analyze-form): Add example 'elisp-scope-analyzer' to docstring. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 00562c4a859..6bea0816927 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -512,7 +512,9 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (defvar elisp-scope--local nil) -(defvar elisp-scope--output-type nil) +(defvar elisp-scope-output-type nil + "Output type of the form currently analyzed, or nil if unknown. +See `elisp-scope-1' for possible values.") (defvar elisp-scope-callback #'ignore) @@ -584,7 +586,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-let-1 (if bare (elisp-scope-local-new bare beg local) local) (cdr bindings) body)) (let ((elisp-scope--local local)) - (elisp-scope-n body elisp-scope--output-type)))) + (elisp-scope-n body elisp-scope-output-type)))) (defun elisp-scope-let (bindings body) (elisp-scope-let-1 elisp-scope--local bindings body)) @@ -600,7 +602,7 @@ Optional argument LOCAL is a local context to extend." (elisp-scope-1 (cadr binding)) (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) (elisp-scope-let* (cdr bindings) body))) - (elisp-scope-n body elisp-scope--output-type))) + (elisp-scope-n body elisp-scope-output-type))) (defun elisp-scope-interactive (intr spec modes) (when (symbol-with-pos-p intr) @@ -701,7 +703,7 @@ Optional argument LOCAL is a local context to extend." beg (length (symbol-name bare)))) (elisp-scope-lambda args body)) -(defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope--output-type)) +(defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope-output-type)) (defvar elisp-scope-flet-alist nil) @@ -2132,7 +2134,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-function-analyzer setopt--set (&optional var val) (elisp-scope-1 var '(symbol . free-variable)) - (elisp-scope-1 val elisp-scope--output-type)) + (elisp-scope-1 val elisp-scope-output-type)) (elisp-scope-define-function-analyzer autoload (&optional func file doc int type) (elisp-scope-1 func '(symbol . function)) @@ -2261,7 +2263,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-loop clauses)) (elisp-scope-define-macro-analyzer named-let (name bindings &rest body) - (elisp-scope-named-let name bindings body elisp-scope--output-type)) + (elisp-scope-named-let name bindings body elisp-scope-output-type)) (elisp-scope-define-macro-analyzer cl-flet (bindings &rest body) (elisp-scope-flet bindings body)) @@ -2414,7 +2416,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (setq l (elisp-scope-local-new bare beg l))) (elisp-scope-1 place)) (elisp-scope-1 (cadr binding)))) - (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope--output-type)))) + (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope-output-type)))) (elisp-scope-define-macro-analyzer setf (&rest args) (elisp-scope-setq args)) @@ -2426,7 +2428,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer with-memoization (&optional place &rest body) (elisp-scope-1 place) - (elisp-scope-n body elisp-scope--output-type)) + (elisp-scope-n body elisp-scope-output-type)) (elisp-scope-define-macro-analyzer cl-pushnew (&rest args) (mapc #'elisp-scope-1 args)) @@ -2436,17 +2438,17 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-macro-analyzer static-if (&optional test then &rest else) (elisp-scope-1 test) - (elisp-scope-1 then elisp-scope--output-type) - (elisp-scope-n else elisp-scope--output-type)) + (elisp-scope-1 then elisp-scope-output-type) + (elisp-scope-n else elisp-scope-output-type)) (elisp-scope-define-macro-analyzer static-when (&optional test &rest body) (elisp-scope-1 test) - (elisp-scope-n body elisp-scope--output-type)) + (elisp-scope-n body elisp-scope-output-type)) (put 'static-unless 'elisp-scope-analyzer #'elisp-scope--analyze-static-when) (elisp-scope-define-macro-analyzer eval-when-compile (&rest body) - (elisp-scope-n body elisp-scope--output-type)) + (elisp-scope-n body elisp-scope-output-type)) (put 'eval-and-compile 'elisp-scope-analyzer #'elisp-scope--analyze-eval-when-compile) @@ -2483,7 +2485,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-1 when)) (elisp-scope-define-macro-analyzer backquote (&optional structure) - (elisp-scope-backquote structure elisp-scope--output-type)) + (elisp-scope-backquote structure elisp-scope-output-type)) (defvar elisp-scope-backquote-depth 0) @@ -2514,7 +2516,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-let* bindings body)) (elisp-scope-define-special-form-analyzer cond (&rest clauses) - (dolist (clause clauses) (elisp-scope-n clause elisp-scope--output-type))) + (dolist (clause clauses) (elisp-scope-n clause elisp-scope-output-type))) (elisp-scope-define-special-form-analyzer setq (&rest args) (elisp-scope-setq args)) @@ -2530,7 +2532,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) (l (elisp-scope-local-new bare beg elisp-scope--local))) (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) - (elisp-scope-1 bodyform elisp-scope--output-type) + (elisp-scope-1 bodyform elisp-scope-output-type) (dolist (handler handlers) (dolist (cond-name (ensure-list (car-safe handler))) (when-let* ((cbeg (elisp-scope-sym-pos cond-name)) @@ -2541,7 +2543,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." ((keywordp cbare) (elisp-scope-report 'constant cbeg clen)) (t (elisp-scope-report 'condition cbeg clen))))) (let ((elisp-scope--local l)) - (elisp-scope-n (cdr handler) elisp-scope--output-type))))) + (elisp-scope-n (cdr handler) elisp-scope-output-type))))) (elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) (elisp-scope-condition-case var bodyform handlers)) @@ -2553,18 +2555,18 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (when arg (elisp-scope-sharpquote arg))) (elisp-scope-define-special-form-analyzer quote (arg) - (elisp-scope-quote arg elisp-scope--output-type)) + (elisp-scope-quote arg elisp-scope-output-type)) (elisp-scope-define-special-form-analyzer if (&optional test then &rest else) (elisp-scope-1 test) - (elisp-scope-1 then elisp-scope--output-type) - (elisp-scope-n else elisp-scope--output-type)) + (elisp-scope-1 then elisp-scope-output-type) + (elisp-scope-n else elisp-scope-output-type)) (elisp-scope-define-special-form-analyzer and (&rest forms) - (elisp-scope-n forms elisp-scope--output-type)) + (elisp-scope-n forms elisp-scope-output-type)) (elisp-scope-define-special-form-analyzer or (&rest forms) - (dolist (form forms) (elisp-scope-1 form elisp-scope--output-type))) + (dolist (form forms) (elisp-scope-1 form elisp-scope-output-type))) (defun elisp-scope-quote (arg &optional outtype) (when outtype @@ -2648,10 +2650,10 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) (elisp-scope-1 tag '(symbol . throw-tag)) - (elisp-scope-n body elisp-scope--output-type)) + (elisp-scope-n body elisp-scope-output-type)) (elisp-scope-define-special-form-analyzer progn (&rest body) - (elisp-scope-n body elisp-scope--output-type)) + (elisp-scope-n body elisp-scope-output-type)) (put 'inline 'elisp-scope-analyzer #'elisp-scope--analyze-progn) (put 'save-current-buffer 'elisp-scope-analyzer #'elisp-scope--analyze-progn) @@ -2662,7 +2664,7 @@ property, or if the current buffer is trusted (see `trusted-content-p')." (mapc #'elisp-scope-1 rest)) (elisp-scope-define-special-form-analyzer prog1 (&rest body) - (when (consp body) (elisp-scope-1 (pop body) elisp-scope--output-type)) + (when (consp body) (elisp-scope-1 (pop body) elisp-scope-output-type)) (elisp-scope-n body)) (put 'unwind-protect 'elisp-scope-analyzer #'elisp-scope--analyze-prog1) @@ -2732,7 +2734,7 @@ are analyzed." ;; Hence we cannot interpret their arguments. ) ((setq this (function-get bare 'elisp-scope-analyzer)) - (let ((elisp-scope--output-type outtype)) (apply this form))) + (let ((elisp-scope-output-type outtype)) (apply this form))) ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) (cond @@ -2782,10 +2784,9 @@ This function recursively analyzes Lisp forms (HEAD . TAIL), usually starting with a top-level form, by inspecting HEAD at each level: - If HEAD is a symbol with a non-nil `elisp-scope-analyzer' symbol - property, then the value of that property specifies an analzyer - function AF that is called as (AF HEAD . TAIL) to analyze the form. - The analyzer function can use `elisp-scope-report-s', `elisp-scope-1' - and `elisp-scope-n' to analyze its arguments. + property, then the value of that property specifies a bespoke analzyer + function, AF, that is called as (AF HEAD . TAIL) to analyze the form. + See more details about writing analyzer functions below. - If HEAD satisfies `functionp', which means it is a function in the running Emacs session, analzye the form as a function call. @@ -2795,7 +2796,18 @@ starting with a top-level form, by inspecting HEAD at each level: - If HEAD is unknown, then the arguments in TAIL are ignored, unless `elisp-scope-assume-func' is non-nil, in which case they are analyzed - as evaluated forms (i.e. HEAD is assumed to be a function)." + as evaluated forms (i.e. HEAD is assumed to be a function). + +An analyzer (function specified via the `elisp-scope-analyzer' property) +can use the functions `elisp-scope-report-s', `elisp-scope-1' and +`elisp-scope-n' to analyze its arguments, and it can consult the +variable `elisp-scope-output-type' to obtain the expected output type of +the analyzed form. For example, the following is a suitable analyzer +for the `identity' function: + + (lambda (fsym arg) + (elisp-scope-report-s fsym \\='function) + (elisp-scope-1 arg elisp-scope-output-type))" (let ((elisp-scope-counter 0) (elisp-scope-callback callback) (read-symbol-shorthands nil) commit ceeeb390f01f0c2fe1e2502a8ad42fa2acdd8e9c Author: Eshel Yaron Date: Thu Oct 2 15:22:51 2025 +0200 ; (elisp-scope-1): Analyze macros with (debug t) as progn Take an Edebug spec of t as an indication that all of the macro's arguments are evaluated, and analyze them as such. Only do so as a fallback for macros that we cannot expand, because expanding can lead to more accurate analysis, e.g. with regards to the output type of the form. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 3e49bad721f..00562c4a859 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2736,7 +2736,6 @@ are analyzed." ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) (cond - ;; ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)) ((elisp-scope-safe-macro-p bare) (let* ((warning-minimum-log-level :emergency) (macroexp-inhibit-compiler-macros t) @@ -2746,7 +2745,8 @@ are analyzed." (macroexpand-all-environment (append (mapcar #'list elisp-scope-unsafe-macros) macroexpand-all-environment)) (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) - (elisp-scope-1 expanded outtype))))) + (elisp-scope-1 expanded outtype))) + ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)))) ((or (functionp bare) (memq bare elisp-scope-local-functions)) (elisp-scope-report-s f 'function) (elisp-scope-n forms)) (t commit cfc58025cd4502c5cca5d00b1d69adde9fe28b53 Author: Eshel Yaron Date: Thu Oct 2 14:19:37 2025 +0200 ; Expand ELisp semantic highlighting documentation * lisp/emacs-lisp/elisp-scope.el (elisp-scope-get-symbol-role-property) (elisp-scope-set-symbol-role-property) (elisp-scope-safe-macro-p, elisp-scope-report-s) (elisp-scope-1, elisp-scope-n): Add docstring. (elisp-scope-analyze-form): * lisp/progmodes/elisp-mode.el (elisp-fontify-semantically): Expand docstring. * etc/NEWS: Refer to 'elisp-fontify-semantically' for documentation. diff --git a/etc/NEWS b/etc/NEWS index 748d9c86eb9..dde3b783877 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1156,7 +1156,8 @@ the previous silence. *** 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. +'elisp-fontify-semantically' to non-nil to enable this feature, and see +its documentation for more information. ** Text mode diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index eb0b1d19a90..3e49bad721f 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -47,6 +47,7 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." ;;;###autoload (defun elisp-scope-get-symbol-role-property (role prop) + "Return value of property PROP for symbol role ROLE." (seq-some (lambda (c) (plist-get (get c 'elisp-scope-role-properties) prop)) (elisp-scope--all-reachable-symbol-roles role))) @@ -64,6 +65,7 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." ;;;###autoload (defun elisp-scope-set-symbol-role-property (role prop value) + "Set value of property PROP for symbol role ROLE to VALUE." (put role 'elisp-scope-role-properties (plist-put (get role 'elisp-scope-role-properties) prop value))) @@ -1615,6 +1617,12 @@ trusted code macro expansion is always safe." rx cl-macrolet nnoo-define-basics)) (defun elisp-scope-safe-macro-p (macro) + "Check whether it is safe to expand MACRO, return non-nil iff so. + +If MACRO is one of the macros in `elisp-scope-unsafe-macros', then it is +never considered safe. Otherwise, MACRO is safe if it specified in +`elisp-scope-safe-macros', or if it has a non-nil `safe-macro' symbol +property, or if the current buffer is trusted (see `trusted-content-p')." (and (not (memq macro elisp-scope-unsafe-macros)) (or (eq elisp-scope-safe-macros t) (memq macro elisp-scope-safe-macros) @@ -1645,7 +1653,7 @@ trusted code macro expansion is always safe." (defmacro elisp-scope-define-macro-analyzer (fsym args &rest body) (declare (indent defun)) - (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + (let ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) `(progn (defun ,helper ,args ,@body) (elisp-scope-define-analyzer ,fsym (f &rest args) @@ -1654,7 +1662,7 @@ trusted code macro expansion is always safe." (defmacro elisp-scope-define-special-form-analyzer (fsym args &rest body) (declare (indent defun)) - (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + (let ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) `(progn (defun ,helper ,args ,@body) (elisp-scope-define-analyzer ,fsym (f &rest args) @@ -2660,12 +2668,52 @@ trusted code macro expansion is always safe." (put 'unwind-protect 'elisp-scope-analyzer #'elisp-scope--analyze-prog1) (defun elisp-scope-report-s (sym role) + "Report that symbol SYM has role ROLE. + +If SYM is not a symbol with position information, do nothing." (when-let* ((beg (elisp-scope-sym-pos sym)) (bare (bare-symbol sym))) (elisp-scope-report role beg (length (symbol-name bare))))) (defvar-local elisp-scope-buffer-file-name nil) (defun elisp-scope-1 (form &optional outtype) + "Analyze FORM as an evaluated form with expected output type OUTTYPE. + +If OUTTYPE is non-nil, it specifies FORM's expected \"output type\". +This guides the analysis of quoted (sub)forms. +OUTTYPE can be one the following: + +- t: FORM evaluates to an arbitrary object. + In other words, OUTTYPE of t conveys no information about FORM. + +- `code': FORM evaluates to a form to be evaluated elsewhere. + The quoted output of FORM will again be analyzed as an evaluated form, + in a \"clean\" local environment. + +- (symbol . ROLE): FORM evaluates to a symbol with role ROLE. + See `elisp-scope-define-symbol-role' for more information about + defining new symbol roles. + +- (repeat . TYPE): FORM evaluates to a list with elements of type TYPE. + +- (cons CARTYPE . CDRTYPE): FORM evaluates to a cons cell whose `car' + has type CARTYPE and whose `cdr' has type CDRTYPE. + +- (equal . VAL): FORM evaluates to VAL (or something `equal' to VAL). + +- (or . TYPES): FORM evaluates to a value that matches one of TYPES. + +For example, to analyze a FORM that evaluates to either a list of major +mode names or just to a single major mode name, use OUTTYPE as follows: + + (elisp-scope-1 FORM \\='(or (repeat . (symbol . major-mode)) + (symbol . major-mode))) + +If FORM in this example is (if (something-p) \\='foo \\='(bar baz)), +then all of `foo', `bar' and `baz' will be analyzed as major mode names. + +See also `elisp-scope-analyze-form' for an details about how subforms +are analyzed." (cond ((consp form) (let* ((f (car form)) (bare (elisp-scope-sym-bare f)) @@ -2706,9 +2754,13 @@ trusted code macro expansion is always safe." (when elisp-scope-assume-func (elisp-scope-n forms))))))) ((symbol-with-pos-p form) (elisp-scope-s form)))) -(defun elisp-scope-n (body &optional outtype) - (while (cdr-safe body) (elisp-scope-1 (pop body))) - (when-let* ((form (car-safe body))) (elisp-scope-1 form outtype))) +(defun elisp-scope-n (forms &optional outtype) + "Analyze FORMS as evaluated forms. + +OUTTYPE is the expected output type of the last form in FORMS, if any. +It is passed to `elisp-scope-1', which see." + (while (cdr-safe forms) (elisp-scope-1 (pop forms))) + (when-let* ((form (car-safe forms))) (elisp-scope-1 form outtype))) ;;;###autoload (defun elisp-scope-analyze-form (callback &optional stream) @@ -2727,7 +2779,23 @@ 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." +starting with a top-level form, by inspecting HEAD at each level: + +- If HEAD is a symbol with a non-nil `elisp-scope-analyzer' symbol + property, then the value of that property specifies an analzyer + function AF that is called as (AF HEAD . TAIL) to analyze the form. + The analyzer function can use `elisp-scope-report-s', `elisp-scope-1' + and `elisp-scope-n' to analyze its arguments. + +- If HEAD satisfies `functionp', which means it is a function in the + running Emacs session, analzye the form as a function call. + +- If HEAD is a safe macro (see `elisp-scope-safe-macro-p'), expand it + and analyzes the resulting form. + +- If HEAD is unknown, then the arguments in TAIL are ignored, unless + `elisp-scope-assume-func' is non-nil, in which case they are analyzed + as evaluated forms (i.e. HEAD is assumed to be a function)." (let ((elisp-scope-counter 0) (elisp-scope-callback callback) (read-symbol-shorthands nil) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 4a84f3509e3..a768a0c39d6 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -284,7 +284,21 @@ Comments in the form will be lost." "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." +the role of each symbol and highlight it accordingly. We call this kind +of highlighting \"semantic highlighting\". + +Semantic highlighting works best when you keep your code syntactically +correct while editing it, for example by using `electric-pair-mode'. + +In trusted buffers (see `trusted-content-p'), the code analysis may +expand some macro calls in your code to analyze the expanded forms. In +untrusted buffers, for security reasons, macro-expansion is restricted +to safe macros only (see `elisp-scope-safe-macro-p'). Hence in +untrusted buffers the arguments of some macros might not be analyzed, +and therefore not highighted. + +See the function `elisp-scope-analyze-form' for more details about the +code analysis." :type 'boolean) (defface elisp-symbol-at-mouse commit f0cab9d27e6a3907ba0057f89b3ed636f97c236c Author: Eshel Yaron Date: Thu Oct 2 09:24:31 2025 +0200 ; Use 'font-lock-keywords' for ELisp semantic highlighting Hook semantic highlighting into 'font-lock-keywords' instead of 'font-lock-fontify-region-function'. See discussion at https://yhetil.org/emacs/jwvseg2mnkx.fsf-monnier+emacs@gnu.org/T/#t * lisp/progmodes/elisp-mode.el (elisp-fontify-region) (elisp-fontify-region-semantically): Remove, no longer used. (elisp-fontify-symbols): New function. (elisp-semantic-font-lock-keywords): New 'defconst'. (emacs-lisp-mode): Use it as the new highest 'font-lock-keywords' level. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 799236d1187..4a84f3509e3 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -539,26 +539,12 @@ that `font-lock-keywords' applied takes precedence, if any." ;; 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) +(defun elisp-fontify-symbols (end) + "Fontify symbols from point to END according to their role in the code." + (when elisp-fontify-semantically (while (< (point) end) (ignore-errors (elisp-scope-analyze-form #'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 @@ -629,6 +615,9 @@ disable it." (defvar-keymap elisp--dynlex-modeline-map " " #'elisp-enable-lexical-binding) +(defconst elisp-semantic-font-lock-keywords + (append lisp-el-font-lock-keywords-2 '((elisp-fontify-symbols)))) + ;;;###autoload (define-derived-mode emacs-lisp-mode lisp-data-mode `("Elisp" @@ -655,14 +644,12 @@ be used instead. (setcar font-lock-defaults '(lisp-el-font-lock-keywords lisp-el-font-lock-keywords-1 - lisp-el-font-lock-keywords-2)) + lisp-el-font-lock-keywords-2 + elisp-semantic-font-lock-keywords)) (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) commit e82620a36046592197069253ad3e0dde01879455 Author: Eshel Yaron Date: Wed Oct 1 13:15:57 2025 +0200 ; elisp-scope.el: Rename 'variable' role to 'free-variable'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index a1e2862990c..eb0b1d19a90 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -131,6 +131,10 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." :namespace 'symbol-role) (elisp-scope-define-symbol-role variable () + :doc "Abstract symbol role of variables." + :namespace 'variable) + +(elisp-scope-define-symbol-role free-variable (variable) :doc "Variable names." :definition 'defvar :face 'elisp-free-variable @@ -141,8 +145,7 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (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) + "Special variable"))) (elisp-scope-define-symbol-role bound-variable (variable) :doc "Local variable names." @@ -541,7 +544,7 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-variable (sym beg len id) (elisp-scope-report - (if id (if (elisp-scope-special-variable-p sym) 'shadowed-variable 'bound-variable) 'variable) + (if id (if (elisp-scope-special-variable-p sym) 'shadowed-variable 'bound-variable) 'free-variable) beg len id)) (defun elisp-scope-binding (sym beg len) @@ -1209,7 +1212,7 @@ Optional argument LOCAL is a local context to extend." (when-let* ((var (car args)) (beg (elisp-scope-sym-pos var)) (bare (elisp-scope-sym-bare var))) - (elisp-scope-report 'variable beg (length (symbol-name bare))))))) + (elisp-scope-report 'free-variable beg (length (symbol-name bare))))))) (defun elisp-scope-quoted-group (sym-form) (when-let* (((eq (elisp-scope-sym-bare (car-safe sym-form)) 'quote)) @@ -1571,7 +1574,7 @@ Optional argument LOCAL is a local context to extend." (defun elisp-scope-mode-line-construct-1 (format) (cond ((symbol-with-pos-p format) - (elisp-scope-report 'variable + (elisp-scope-report 'free-variable (symbol-with-pos-pos format) (length (symbol-name (bare-symbol format))))) ((consp format) @@ -1905,7 +1908,7 @@ trusted code macro expansion is always safe." (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-kill-emacs)) (elisp-scope-define-function-analyzer run-hooks (&rest hooks) - (dolist (hook hooks) (elisp-scope-1 hook '(symbol . variable)))) + (dolist (hook hooks) (elisp-scope-1 hook '(symbol . free-variable)))) (elisp-scope-define-function-analyzer fboundp (&optional symbol) (elisp-scope-1 symbol '(symbol . function))) @@ -1942,7 +1945,7 @@ trusted code macro expansion is always safe." (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-facep)) (elisp-scope-define-function-analyzer boundp (&optional var &rest rest) - (elisp-scope-1 var '(symbol . variable)) + (elisp-scope-1 var '(symbol . free-variable)) (elisp-scope-n rest)) (dolist (sym '( set symbol-value define-abbrev-table @@ -1957,7 +1960,7 @@ trusted code macro expansion is always safe." (elisp-scope-define-function-analyzer defvaralias (new base &optional docstring) (elisp-scope-1 new '(symbol . defvar)) - (elisp-scope-1 base '(symbol . variable)) + (elisp-scope-1 base '(symbol . free-variable)) (elisp-scope-1 docstring)) (elisp-scope-define-function-analyzer define-error (&optional name message parent) @@ -2057,7 +2060,7 @@ trusted code macro expansion is always safe." (dolist (arg args) (elisp-scope-1 arg - '(cons (symbol . variable) . + '(cons (symbol . free-variable) . (cons code . (or (cons t . (cons (repeat . (symbol . feature)) . @@ -2120,7 +2123,7 @@ trusted code macro expansion is always safe." (elisp-scope-1 kws))) (elisp-scope-define-function-analyzer setopt--set (&optional var val) - (elisp-scope-1 var '(symbol . variable)) + (elisp-scope-1 var '(symbol . free-variable)) (elisp-scope-1 val elisp-scope--output-type)) (elisp-scope-define-function-analyzer autoload (&optional func file doc int type) commit 737d99e4ed342df91b53134d74af98700c95bb23 Author: Eshel Yaron Date: Wed Oct 1 12:58:31 2025 +0200 ; Fix recent small mistake in recent refactor. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 1eb385dbddb..a1e2862990c 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -281,9 +281,9 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." :namespace 'widget-type) (elisp-scope-define-symbol-role widget-type-definition (widget-type) - :doc "Widget role definitions." + :doc "Widget type definitions." :imenu "Widget" - :help (cl-constantly "Widget role definition")) + :help (cl-constantly "Widget type definition")) (elisp-scope-define-symbol-role type () :doc "ELisp object type names." commit c2d01dda422550f36ca196f27f200ffe7dfee499 Author: Eshel Yaron Date: Wed Oct 1 08:56:55 2025 +0200 ; elisp-scope.el: Simplify 'eval' analyzer. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index f91f052fbb1..1eb385dbddb 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1671,9 +1671,12 @@ trusted code macro expansion is always safe." (elisp-scope-define-analyzer eval (f form &optional lexical) (elisp-scope-report-s f 'function) - (if-let* ((quoted (elisp-scope--unquote form))) - (elisp-scope-1 quoted) - (elisp-scope-1 form)) + ;; TODO: Use elisp-scope-1 with outtype `code' in the next line. + ;; Difficulty: that would analyze the quoted code as if it is + ;; evaluated in an unrelated local environment, so local variables + ;; wouldn't be recognized correctly etc. We can solve that by adding + ;; some `code-evaled-here' outtype. + (elisp-scope-1 (or (elisp-scope--unquote form) form)) (elisp-scope-1 lexical)) (elisp-scope-define-function-analyzer funcall (&optional f &rest args) commit 3cff47ec75a40fd7309e75bd42b9d598ad079be0 Author: Eshel Yaron Date: Wed Oct 1 08:42:40 2025 +0200 ; elisp-scope.el: Rename 'declaration' role. * lisp/emacs-lisp/elisp-scope.el (declaration): Rename to 'function-property-declaration'. (elisp-scope-lambda): * lisp/progmodes/elisp-mode.el (elisp-function-property-declaration): Update accordingly. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 5cb9a15f12a..f91f052fbb1 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -242,10 +242,10 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." :imenu "Feature" :help (cl-constantly "Feature definition")) -(elisp-scope-define-symbol-role declaration () - :doc "Function attribute declaration types." - :face 'elisp-declaration - :help (cl-constantly "Declaration")) +(elisp-scope-define-symbol-role function-property-declaration () + :doc "Function/macro property declaration types." + :face 'elisp-function-property-declaration + :help (cl-constantly "Function/macro property declaration")) (elisp-scope-define-symbol-role rx-construct () :doc "`rx' constructs." @@ -637,7 +637,7 @@ Optional argument LOCAL is a local context to extend." (when-let* ((head (car-safe spec)) (bare (elisp-scope-sym-bare head))) (when (symbol-with-pos-p head) - (elisp-scope-report 'declaration + (elisp-scope-report 'function-property-declaration (symbol-with-pos-pos head) (length (symbol-name bare)))) (cl-case bare diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index d470adba780..799236d1187 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -358,8 +358,8 @@ the role of each symbol and highlight it accordingly." (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-function-property-declaration '((t :inherit font-lock-variable-use-face)) + "Face for highlighting function/macro property declaration type names.") (defface elisp-thing '((t :inherit font-lock-type-face)) "Face for highlighting `thing-at-point' \"thing\" names in Emacs Lisp.") commit a7c1b126fac0d704c5488bef34003bf7187c3692 Author: Eshel Yaron Date: Wed Oct 1 08:37:44 2025 +0200 ; elisp-scope.el: Remove unused 'undefined-macro' role. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index b2d676e2887..5cb9a15f12a 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -212,10 +212,6 @@ NAME inherits properties that do not appear in PROPS from its PARENTS." (apply-partially #'elisp--function-help-echo sym) "Macro call"))) -(elisp-scope-define-symbol-role undefined-macro (macro) - :doc "Known macro names whose definition is unknown." - :help (cl-constantly "Call to macro with unknown definition")) - (elisp-scope-define-symbol-role special-form (callable) :doc "Special form names." :face 'elisp-special-form commit 7217350e854ba4bde8d610a1055c9e90dc172c1a Author: Eshel Yaron Date: Wed Oct 1 08:34:58 2025 +0200 ; elisp-scope.el: Fix 'define-completion-category' handler. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 0a336b2299f..b2d676e2887 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -2131,7 +2131,7 @@ trusted code macro expansion is always safe." (elisp-scope-1 int '(repeat . (symbol . major-mode))) (elisp-scope-1 type)) -(elisp-scope-define-function-analyzer minibuffer--define-completion-category (&optional name parents &rest rest) +(elisp-scope-define-function-analyzer define-completion-category (&optional name parents &rest rest) (elisp-scope-1 name '(symbol . completion-category-definition)) (elisp-scope-1 parents '(repeat . (symbol . completion-category))) (elisp-scope-n rest)) commit 23ba18037b67cb8a0ff5d13be9d32609601910cc Author: Eshel Yaron Date: Wed Oct 1 08:31:20 2025 +0200 ; (elisp-scope-define-symbol-role): Add docstring. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index e27f7f69aac..0a336b2299f 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -34,6 +34,14 @@ (put name 'elisp-scope-role-properties props)) (defmacro elisp-scope-define-symbol-role (name parents &rest props) + "Define NAME as the name of a symbol role that inherits from PARENTS. + +A symbol role is a symbol that Emacs uses to describe the role +of (other) symbols in ELisp source code. For example, the symbol role +`face' characterizes symbols that are face names. + +PROPS is a plist specifying the properties of the new symbol role NAME. +NAME inherits properties that do not appear in PROPS from its PARENTS." (declare (indent defun)) `(elisp-scope--define-symbol-role ',name ',parents ,(when props `(list ,@props)))) commit 2447c1486eec084eb2fe5a433bbe61749b27155d Author: Eshel Yaron Date: Wed Oct 1 08:09:06 2025 +0200 ; Call it "symbol role" instead of "symbol type". Change the terminology used in elisp-scope.el to call the symbols we use to categorizes the use of (other) symbols "symbol roles" instead of "symbol types". * lisp/emacs-lisp/elisp-scope.el: * lisp/progmodes/elisp-mode.el: Change all occurrences of "symbol type" say "role" instead. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 6576705dd2e..e27f7f69aac 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -29,100 +29,100 @@ (require 'cl-lib) -(defun elisp-scope--define-symbol-type (name parents props) - (put name 'elisp-scope-parent-types parents) - (put name 'elisp-scope-type-properties props)) +(defun elisp-scope--define-symbol-role (name parents props) + (put name 'elisp-scope-parent-roles parents) + (put name 'elisp-scope-role-properties props)) -(defmacro elisp-scope-define-symbol-type (name parents &rest props) +(defmacro elisp-scope-define-symbol-role (name parents &rest props) (declare (indent defun)) - `(elisp-scope--define-symbol-type ',name ',parents ,(when props `(list ,@props)))) + `(elisp-scope--define-symbol-role ',name ',parents ,(when props `(list ,@props)))) ;;;###autoload -(defun elisp-scope-get-symbol-type-property (type prop) +(defun elisp-scope-get-symbol-role-property (role prop) (seq-some - (lambda (c) (plist-get (get c 'elisp-scope-type-properties) prop)) - (elisp-scope--all-reachable-symbol-types type))) + (lambda (c) (plist-get (get c 'elisp-scope-role-properties) prop)) + (elisp-scope--all-reachable-symbol-roles role))) -(defvar elisp-scope--all-reachable-symbol-types-cache (make-hash-table)) +(defvar elisp-scope--all-reachable-symbol-roles-cache (make-hash-table)) -(defun elisp-scope--all-reachable-symbol-types (symbol-type) - (with-memoization (gethash symbol-type elisp-scope--all-reachable-symbol-types-cache) - (cons symbol-type - (let* ((parents (get symbol-type 'elisp-scope-parent-types)) - (aps (mapcar #'elisp-scope--all-reachable-symbol-types parents))) +(defun elisp-scope--all-reachable-symbol-roles (symbol-role) + (with-memoization (gethash symbol-role elisp-scope--all-reachable-symbol-roles-cache) + (cons symbol-role + (let* ((parents (get symbol-role 'elisp-scope-parent-roles)) + (aps (mapcar #'elisp-scope--all-reachable-symbol-roles parents))) (if (cdr aps) (merge-ordered-lists (nconc aps (list parents))) (car aps)))))) ;;;###autoload -(defun elisp-scope-set-symbol-type-property (type prop value) - (put type 'elisp-scope-type-properties - (plist-put (get type 'elisp-scope-type-properties) prop value))) +(defun elisp-scope-set-symbol-role-property (role prop value) + (put role 'elisp-scope-role-properties + (plist-put (get role 'elisp-scope-role-properties) prop value))) ;;;###autoload -(defun elisp-scope-symbol-type-p (sym) - (or (get sym 'elisp-scope-parent-types) (get sym 'elisp-scope-type-properties))) +(defun elisp-scope-symbol-role-p (sym) + (or (get sym 'elisp-scope-parent-roles) (get sym 'elisp-scope-role-properties))) -(defvar elisp-scope-read-symbol-type-history nil) +(defvar elisp-scope-read-symbol-role-history nil) -(defun elisp-scope-read-symbol-type (prompt &optional default) +(defun elisp-scope-read-symbol-role (prompt &optional default) (completing-read (format-prompt prompt default) - obarray #'elisp-scope-symbol-type-p 'confirm - nil 'elisp-scope-read-symbol-type-history default)) + obarray #'elisp-scope-symbol-role-p 'confirm + nil 'elisp-scope-read-symbol-role-history default)) (defvar help-mode--current-data) ;;;###autoload -(defun elisp-scope-describe-symbol-type (type) - (interactive (list (elisp-scope-read-symbol-type - "Describe symbol type" +(defun elisp-scope-describe-symbol-role (role) + (interactive (list (elisp-scope-read-symbol-role + "Describe symbol role" (when-let* ((def (symbol-at-point)) - ((elisp-scope-symbol-type-p def))) + ((elisp-scope-symbol-role-p def))) def)))) - (when (stringp type) (setq type (intern type))) + (when (stringp role) (setq role (intern role))) (let ((help-buffer-under-preparation t)) - (help-setup-xref (list #'elisp-scope-describe-symbol-type type) + (help-setup-xref (list #'elisp-scope-describe-symbol-role role) (called-interactively-p 'interactive)) (with-help-window (help-buffer) (with-current-buffer standard-output - (insert "Symbol type " - (substitute-quotes (concat "`" (symbol-name type) "'")) + (insert "Symbol role " + (substitute-quotes (concat "`" (symbol-name role) "'")) ":\n\n" (substitute-quotes - (or (elisp-scope-get-symbol-type-property type :doc) + (or (elisp-scope-get-symbol-role-property role :doc) "Undocumented."))) - (when-let* ((parents (get type 'elisp-scope-parent-types))) - (insert "\n\nParent types: " + (when-let* ((parents (get role 'elisp-scope-parent-roles))) + (insert "\n\nParent roles: " (mapconcat (lambda (parent) (let ((name (symbol-name parent))) (substitute-quotes (concat "`" (buttonize - name #'elisp-scope-describe-symbol-type name - "mouse-2, RET: describe this symbol type") + name #'elisp-scope-describe-symbol-role name + "mouse-2, RET: describe this symbol role") "'")))) parents ", "))) (setq help-mode--current-data - (list :symbol type :type 'define-symbol-type - :file (find-lisp-object-file-name type 'define-symbol-type))))))) - -(elisp-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) - -(elisp-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) - -(elisp-scope-define-symbol-type variable () + (list :symbol role :type 'define-symbol-role + :file (find-lisp-object-file-name role 'define-symbol-role))))))) + +(elisp-scope-define-symbol-role symbol-role () + :doc "Symbol role names." + :definition 'symbol-role-definition + :face 'elisp-symbol-role + :help (cl-constantly "Symbol role") + :namespace 'symbol-role) + +(elisp-scope-define-symbol-role symbol-role-definition (symbol-role) + :doc "Symbol role name definitions." + :face 'elisp-symbol-role-definition + :help (cl-constantly "Symbol role definition") + :imenu "Symbol Role" + :namespace 'symbol-role) + +(elisp-scope-define-symbol-role variable () :doc "Variable names." :definition 'defvar :face 'elisp-free-variable @@ -136,27 +136,27 @@ "Special variable")) :namespace 'variable) -(elisp-scope-define-symbol-type bound-variable (variable) +(elisp-scope-define-symbol-role bound-variable (variable) :doc "Local variable names." :face 'elisp-bound-variable :help (cl-constantly "Local variable")) -(elisp-scope-define-symbol-type binding-variable (bound-variable) +(elisp-scope-define-symbol-role binding-variable (bound-variable) :doc "Local variable definitions." :face 'elisp-binding-variable :help (cl-constantly "Local variable binding")) -(elisp-scope-define-symbol-type shadowed-variable (variable) +(elisp-scope-define-symbol-role shadowed-variable (variable) :doc "Locally shadowed variable names." :face 'elisp-shadowed-variable :help (cl-constantly "Locally shadowed variable")) -(elisp-scope-define-symbol-type shadowing-variable (shadowed-variable) +(elisp-scope-define-symbol-role shadowing-variable (shadowed-variable) :doc "Local variable definitions." :face 'elisp-shadowing-variable :help (cl-constantly "Local variable shadowing")) -(elisp-scope-define-symbol-type face () +(elisp-scope-define-symbol-role face () :doc "Face names." :definition 'defface :face 'elisp-face @@ -164,11 +164,11 @@ (elisp--help-echo beg end 'face-documentation "Face")) :namespace 'face) -(elisp-scope-define-symbol-type callable () - :doc "Abstract symbol type of function-like symbols." +(elisp-scope-define-symbol-role callable () + :doc "Abstract symbol role of function-like symbols." :namespace 'function) -(elisp-scope-define-symbol-type function (callable) +(elisp-scope-define-symbol-role function (callable) :doc "Function names." :definition '(defun defcmd) :face 'elisp-function-reference @@ -179,15 +179,15 @@ (apply-partially #'elisp--function-help-echo sym) "Function call"))))) -(elisp-scope-define-symbol-type command (function) +(elisp-scope-define-symbol-role command (function) :doc "Command names.") -(elisp-scope-define-symbol-type unknown (function) +(elisp-scope-define-symbol-role unknown (function) :doc "Unknown symbols at function position." :face 'elisp-unknown-call :help (cl-constantly "Unknown callable")) -(elisp-scope-define-symbol-type non-local-exit (function) +(elisp-scope-define-symbol-role non-local-exit (function) :doc "Functions that do not return." :face 'elisp-non-local-exit :help (lambda (beg end _def) @@ -195,7 +195,7 @@ (apply-partially #'elisp--function-help-echo sym) "Non-local exit"))) -(elisp-scope-define-symbol-type macro (callable) +(elisp-scope-define-symbol-role macro (callable) :doc "Macro names." :definition 'defmacro :face 'elisp-macro-call @@ -204,11 +204,11 @@ (apply-partially #'elisp--function-help-echo sym) "Macro call"))) -(elisp-scope-define-symbol-type undefined-macro (macro) +(elisp-scope-define-symbol-role undefined-macro (macro) :doc "Known macro names whose definition is unknown." :help (cl-constantly "Call to macro with unknown definition")) -(elisp-scope-define-symbol-type special-form (callable) +(elisp-scope-define-symbol-role special-form (callable) :doc "Special form names." :face 'elisp-special-form :help (lambda (beg end _def) @@ -216,98 +216,98 @@ (apply-partially #'elisp--function-help-echo sym) "Special form"))) -(elisp-scope-define-symbol-type throw-tag () +(elisp-scope-define-symbol-role throw-tag () :doc "Symbols used as `throw'/`catch' tags." :face 'elisp-throw-tag :help (cl-constantly "`throw'/`catch' tag")) -(elisp-scope-define-symbol-type warning-type () +(elisp-scope-define-symbol-role warning-type () :doc "Byte-compilation warning types." :face 'elisp-warning-type :help (cl-constantly "Warning type")) -(elisp-scope-define-symbol-type feature () +(elisp-scope-define-symbol-role feature () :doc "Feature names." :definition 'deffeature :face 'elisp-feature :help (cl-constantly "Feature") :namespace 'feature) -(elisp-scope-define-symbol-type deffeature (feature) +(elisp-scope-define-symbol-role deffeature (feature) :doc "Feature definitions." :imenu "Feature" :help (cl-constantly "Feature definition")) -(elisp-scope-define-symbol-type declaration () +(elisp-scope-define-symbol-role declaration () :doc "Function attribute declaration types." :face 'elisp-declaration :help (cl-constantly "Declaration")) -(elisp-scope-define-symbol-type rx-construct () +(elisp-scope-define-symbol-role rx-construct () :doc "`rx' constructs." :face 'elisp-rx :help (cl-constantly "`rx' construct")) -(elisp-scope-define-symbol-type theme () +(elisp-scope-define-symbol-role theme () :doc "Custom theme names." :definition 'deftheme :face 'elisp-theme :help (cl-constantly "Theme")) -(elisp-scope-define-symbol-type deftheme (theme) +(elisp-scope-define-symbol-role deftheme (theme) :doc "Custom theme definitions." :imenu "Theme" :help (cl-constantly "Theme definition")) -(elisp-scope-define-symbol-type thing () +(elisp-scope-define-symbol-role thing () :doc "`thing-at-point' \"thing\" identifiers." :face 'elisp-thing :help (cl-constantly "Thing (text object)")) -(elisp-scope-define-symbol-type slot () +(elisp-scope-define-symbol-role slot () :doc "EIEIO slots." :face 'elisp-slot :help (cl-constantly "Slot")) -(elisp-scope-define-symbol-type widget-type () +(elisp-scope-define-symbol-role widget-type () :doc "Widget types." :definition 'widget-type-definition :face 'elisp-widget-type :help (cl-constantly "Widget type") :namespace 'widget-type) -(elisp-scope-define-symbol-type widget-type-definition (widget-type) - :doc "Widget type definitions." +(elisp-scope-define-symbol-role widget-type-definition (widget-type) + :doc "Widget role definitions." :imenu "Widget" - :help (cl-constantly "Widget type definition")) + :help (cl-constantly "Widget role definition")) -(elisp-scope-define-symbol-type type () +(elisp-scope-define-symbol-role type () :doc "ELisp object type names." :face 'elisp-type :help (cl-constantly "Type")) -(elisp-scope-define-symbol-type deftype (type) +(elisp-scope-define-symbol-role deftype (type) :doc "ELisp object type definitions." :imenu "Type" :help (cl-constantly "Type definition")) -(elisp-scope-define-symbol-type group () +(elisp-scope-define-symbol-role group () :doc "Customization groups." :definition 'defgroup :face 'elisp-group :help (cl-constantly "Customization group")) -(elisp-scope-define-symbol-type defgroup (group) +(elisp-scope-define-symbol-role defgroup (group) :doc "Customization group definitions." :imenu "Group" :help (cl-constantly "Customization group definition")) -(elisp-scope-define-symbol-type nnoo-backend () +(elisp-scope-define-symbol-role nnoo-backend () :doc "`nnoo' backend names." :face 'elisp-nnoo-backend :help (cl-constantly "`nnoo' backend")) -(elisp-scope-define-symbol-type condition () +(elisp-scope-define-symbol-role condition () :doc "`condition-case' conditions." :definition 'defcondition :face 'elisp-condition @@ -322,22 +322,22 @@ "`condition-case' condition")) :namespace 'condition) -(elisp-scope-define-symbol-type defcondition (condition) +(elisp-scope-define-symbol-role defcondition (condition) :doc "`condition-case' condition definitions." :definition 'defcondition :help (cl-constantly "`condition-case' condition definition")) -(elisp-scope-define-symbol-type ampersand () +(elisp-scope-define-symbol-role ampersand () :doc "Argument list markers, such as `&optional' and `&rest'." :face 'elisp-ampersand :help (cl-constantly "Arguments separator")) -(elisp-scope-define-symbol-type constant () +(elisp-scope-define-symbol-role constant () :doc "Self-evaluating symbols." :face 'elisp-constant :help (cl-constantly "Constant")) -(elisp-scope-define-symbol-type defun () +(elisp-scope-define-symbol-role defun () :doc "Function definitions." :definition 'defun :face 'elisp-defun @@ -345,7 +345,7 @@ :imenu "Function" :namespace 'function) -(elisp-scope-define-symbol-type defmacro () +(elisp-scope-define-symbol-role defmacro () :doc "Macro definitions." :definition 'defmacro :face 'elisp-defmacro @@ -353,13 +353,13 @@ :imenu "Macro" :namespace 'function) -(elisp-scope-define-symbol-type defcmd (defun) +(elisp-scope-define-symbol-role defcmd (defun) :doc "Command definitions." :definition 'defcmd :help (cl-constantly "Command definition") :imenu "Command") -(elisp-scope-define-symbol-type defvar () +(elisp-scope-define-symbol-role defvar () :doc "Variable definitions." :definition 'defvar :face 'elisp-defvar @@ -367,7 +367,7 @@ :imenu "Variable" :namespace 'variable) -(elisp-scope-define-symbol-type defface () +(elisp-scope-define-symbol-role defface () :doc "Face definitions." :definition 'defface :face 'elisp-defface @@ -375,7 +375,7 @@ :imenu "Face" :namespace 'face) -(elisp-scope-define-symbol-type major-mode () +(elisp-scope-define-symbol-role major-mode () :doc "Major mode names." :definition 'major-mode-definition :face 'elisp-major-mode-name @@ -388,24 +388,24 @@ "Major mode")) :namespace 'function) -(elisp-scope-define-symbol-type major-mode-definition (major-mode) +(elisp-scope-define-symbol-role major-mode-definition (major-mode) :doc "Major mode definitions." :help (cl-constantly "Major mode definition") :imenu "Major Mode") -(elisp-scope-define-symbol-type block () +(elisp-scope-define-symbol-role block () :doc "`cl-block' block names." :help (lambda (beg _end def) (if (equal beg def) "Block definition" "Block"))) -(elisp-scope-define-symbol-type icon () +(elisp-scope-define-symbol-role icon () :doc "Icon names." :definition 'deficon :face 'elisp-icon :help (cl-constantly "Icon") :namespace 'icon) -(elisp-scope-define-symbol-type deficon () +(elisp-scope-define-symbol-role deficon () :doc "Icon definitions." :definition 'deficon :face 'elisp-deficon @@ -413,7 +413,7 @@ :imenu "Icon" :namespace 'icon) -(elisp-scope-define-symbol-type oclosure () +(elisp-scope-define-symbol-role oclosure () :doc "OClosure type names." :definition 'defoclosure :face 'elisp-oclosure @@ -426,7 +426,7 @@ "OClosure type")) :namespace 'oclosure) -(elisp-scope-define-symbol-type defoclosure () +(elisp-scope-define-symbol-role defoclosure () :doc "OClosure type definitions." :definition 'defoclosure :face 'elisp-defoclosure @@ -434,7 +434,7 @@ :imenu "OClosure type" :namespace 'oclosure) -(elisp-scope-define-symbol-type coding () +(elisp-scope-define-symbol-role coding () :doc "Coding system names." :definition 'defcoding :face 'elisp-coding @@ -447,7 +447,7 @@ "Coding system")) :namespace 'coding) -(elisp-scope-define-symbol-type defcoding () +(elisp-scope-define-symbol-role defcoding () :doc "Coding system definitions." :definition 'defcoding :face 'elisp-defcoding @@ -455,7 +455,7 @@ :imenu "Coding system" :namespace 'coding) -(elisp-scope-define-symbol-type charset () +(elisp-scope-define-symbol-role charset () :doc "Charset names." :definition 'defcharset :face 'elisp-charset @@ -468,7 +468,7 @@ "Charset")) :namespace 'charset) -(elisp-scope-define-symbol-type defcharset () +(elisp-scope-define-symbol-role defcharset () :doc "Charset definitions." :definition 'defcharset :face 'elisp-defcharset @@ -476,7 +476,7 @@ :imenu "Charset" :namespace 'charset) -(elisp-scope-define-symbol-type completion-category () +(elisp-scope-define-symbol-role completion-category () :doc "Completion categories." :definition 'completion-category-definition :face 'elisp-completion-category @@ -489,7 +489,7 @@ "Completion category")) :namespace 'completion-category) -(elisp-scope-define-symbol-type completion-category-definition () +(elisp-scope-define-symbol-role completion-category-definition () :doc "Completion category definitions." :definition 'completion-category-definition :face 'elisp-completion-category-definition @@ -527,8 +527,8 @@ Optional argument LOCAL is a local context to extend." (defvar elisp-scope--quoted nil) -(defsubst elisp-scope-report (type beg len &optional id def) - (funcall elisp-scope-callback type beg len id (or def (and (numberp id) id)))) +(defsubst elisp-scope-report (role beg len &optional id def) + (funcall elisp-scope-callback role beg len id (or def (and (numberp id) id)))) (defvar elisp-scope-special-variables nil) @@ -1623,13 +1623,13 @@ trusted code macro expansion is always safe." (defun ,analyzer ,args ,@body) (put ',fsym 'elisp-scope-analyzer #',analyzer)))) -(defmacro elisp-scope--define-function-analyzer (fsym args type &rest body) +(defmacro elisp-scope--define-function-analyzer (fsym args role &rest body) (declare (indent defun)) (let ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) `(progn (defun ,helper ,args ,@body) (elisp-scope-define-analyzer ,fsym (f &rest args) - (elisp-scope-report-s f ',type) + (elisp-scope-report-s f ',role) (apply #',helper args))))) (defmacro elisp-scope-define-function-analyzer (fsym args &rest body) @@ -2085,12 +2085,12 @@ trusted code macro expansion is always safe." (elisp-scope-1 parent '(symbol . major-mode))) (elisp-scope-define-function-analyzer elisp-scope-report (type &rest args) - (elisp-scope-1 type '(symbol . symbol-type)) + (elisp-scope-1 type '(symbol . symbol-role)) (mapc #'elisp-scope-1 args)) (elisp-scope-define-function-analyzer elisp-scope-report-s (&optional sym type) (elisp-scope-1 sym) - (elisp-scope-1 type '(symbol . symbol-type))) + (elisp-scope-1 type '(symbol . symbol-role))) (elisp-scope-define-function-analyzer elisp-scope-1 (&optional form outtype) (elisp-scope-1 form) @@ -2366,9 +2366,9 @@ trusted code macro expansion is always safe." (put 'ert-deftest 'elisp-scope-analyzer #'elisp-scope--analyze-defun) -(elisp-scope-define-macro-analyzer elisp-scope-define-symbol-type (&optional name parents &rest props) - (elisp-scope-report-s name 'symbol-type-definition) - (dolist (parent parents) (elisp-scope-report-s parent 'symbol-type)) +(elisp-scope-define-macro-analyzer elisp-scope-define-symbol-role (&optional name parents &rest props) + (elisp-scope-report-s name 'symbol-role-definition) + (dolist (parent parents) (elisp-scope-report-s parent 'symbol-role)) (while-let ((kw (car-safe props)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) @@ -2379,7 +2379,7 @@ trusted code macro expansion is always safe." (elisp-scope-1 (cadr props)))) (:definition (if-let* ((q (elisp-scope--unquote (cadr props)))) - (dolist (st (ensure-list q)) (elisp-scope-report-s st 'symbol-type)) + (dolist (st (ensure-list q)) (elisp-scope-report-s st 'symbol-role)) (elisp-scope-1 (cadr props)))) (otherwise (elisp-scope-1 (cadr props)))) (setq props (cddr props)))) @@ -2593,7 +2593,7 @@ trusted code macro expansion is always safe." '(or (equal . t) (equal . code) (equal . type) - (cons (equal . symbol) . (symbol . symbol-type)) + (cons (equal . symbol) . (symbol . symbol-role)) (cons (equal . repeat) . type) (cons (equal . or) . (repeat . type)) (cons (equal . cons) . (cons type . type)) @@ -2649,9 +2649,9 @@ trusted code macro expansion is always safe." (put 'unwind-protect 'elisp-scope-analyzer #'elisp-scope--analyze-prog1) -(defun elisp-scope-report-s (sym type) +(defun elisp-scope-report-s (sym role) (when-let* ((beg (elisp-scope-sym-pos sym)) (bare (bare-symbol sym))) - (elisp-scope-report type beg (length (symbol-name bare))))) + (elisp-scope-report role beg (length (symbol-name bare))))) (defvar-local elisp-scope-buffer-file-name nil) @@ -2704,8 +2704,8 @@ trusted code macro expansion is always safe." (defun elisp-scope-analyze-form (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 +Call CALLBACK for each analyzed symbol SYM with arguments ROLE, POS, +LEN, ID and DEF, where ROLE 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. diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index d35bddc1a45..d470adba780 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -304,10 +304,10 @@ the role of each symbol and highlight it accordingly." (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)) +(defface elisp-symbol-role '((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)) +(defface elisp-symbol-role-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)) @@ -491,7 +491,7 @@ the role of each symbol and highlight it accordingly." (when elisp-add-help-echo (put-text-property beg end 'help-echo - (when-let* ((fun (elisp-scope-get-symbol-type-property type :help))) + (when-let* ((fun (elisp-scope-get-symbol-role-property type :help))) (funcall fun beg end def))))) (defvar font-lock-beg) @@ -524,7 +524,7 @@ that `font-lock-keywords' applied takes precedence, if any." (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 (elisp-scope-get-symbol-type-property type :face))) + (let ((face (elisp-scope-get-symbol-role-property type :face))) (add-face-text-property beg end face (cl-case elisp-fontify-symbol-precedence-function commit 8c2f783591070fea2fecdb6b2f8a01e71b814a40 Author: Eshel Yaron Date: Wed Oct 1 06:54:13 2025 +0200 (elisp-scope-get-symbol-type-property): Revise inheritance handling. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 7c8edff8593..6576705dd2e 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -29,10 +29,7 @@ (require 'cl-lib) -(defvar elisp-scope--symbol-type-property-cache (make-hash-table)) - (defun elisp-scope--define-symbol-type (name parents props) - (clrhash elisp-scope--symbol-type-property-cache) (put name 'elisp-scope-parent-types parents) (put name 'elisp-scope-type-properties props)) @@ -42,25 +39,23 @@ ;;;###autoload (defun elisp-scope-get-symbol-type-property (type prop) - (with-memoization (alist-get prop (gethash type elisp-scope--symbol-type-property-cache)) - (named-let loop ((current type) - (parents (get type 'elisp-scope-parent-types)) - (more nil) - (done nil)) - (or (plist-get (get current 'elisp-scope-type-properties) prop) - (when-let* ((next (car parents))) - (loop (car parents) (get next 'elisp-scope-parent-types) (append (cdr parents) more) done)) - (when-let* ((next (car more))) - (loop next (let (res) - (dolist (per (get next 'elisp-scope-parent-types)) - (unless (memq per done) - (push per res))) - (nreverse res)) - (cdr more) done)))))) + (seq-some + (lambda (c) (plist-get (get c 'elisp-scope-type-properties) prop)) + (elisp-scope--all-reachable-symbol-types type))) + +(defvar elisp-scope--all-reachable-symbol-types-cache (make-hash-table)) + +(defun elisp-scope--all-reachable-symbol-types (symbol-type) + (with-memoization (gethash symbol-type elisp-scope--all-reachable-symbol-types-cache) + (cons symbol-type + (let* ((parents (get symbol-type 'elisp-scope-parent-types)) + (aps (mapcar #'elisp-scope--all-reachable-symbol-types parents))) + (if (cdr aps) + (merge-ordered-lists (nconc aps (list parents))) + (car aps)))))) ;;;###autoload (defun elisp-scope-set-symbol-type-property (type prop value) - (clrhash elisp-scope--symbol-type-property-cache) (put type 'elisp-scope-type-properties (plist-put (get type 'elisp-scope-type-properties) prop value))) commit 409abfe96e59a36be3124c3762b47d39cbd88e38 Author: Eshel Yaron Date: Tue Sep 30 19:05:21 2025 +0200 ; (elisp-scope-define-symbol-type): Cease autoloading it. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index b38af830488..7c8edff8593 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -36,7 +36,6 @@ (put name 'elisp-scope-parent-types parents) (put name 'elisp-scope-type-properties props)) -;;;###autoload (defmacro elisp-scope-define-symbol-type (name parents &rest props) (declare (indent defun)) `(elisp-scope--define-symbol-type ',name ',parents ,(when props `(list ,@props)))) commit 3ebd0efd094e9ded715baa2db64ab818a95e56dc Author: Eshel Yaron Date: Tue Sep 30 18:30:44 2025 +0200 ; elisp-scope.el: Update multiple function handlers. Update all remaining function handlers to use 'elisp-scope-define-func-analyzer' instead of 'elisp-scope-define-function-analyzer'. The difference is that the former handles all arguments explicitly, while the latter analyzes all arguments as evaluated forms automatically. By handling the arguments explicitly, we get a chance to specify the expected type of different arguments. Lastly, since 'elisp-scope-define-function-analyzer' is now unused, rename 'elisp-scope-define-func-analyzer' to 'elisp-scope-define-function-analyzer'. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el index 74f7fd93ae3..b38af830488 100644 --- a/lisp/emacs-lisp/elisp-scope.el +++ b/lisp/emacs-lisp/elisp-scope.el @@ -1631,34 +1631,16 @@ trusted code macro expansion is always safe." (defmacro elisp-scope--define-function-analyzer (fsym args type &rest body) (declare (indent defun)) - (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + (let ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) `(progn (defun ,helper ,args ,@body) (elisp-scope-define-analyzer ,fsym (f &rest args) (elisp-scope-report-s f ',type) - (apply #',helper args) - (elisp-scope-n args))))) + (apply #',helper args))))) (defmacro elisp-scope-define-function-analyzer (fsym args &rest body) (declare (indent defun)) - `(elisp-scope--define-function-analyzer ,fsym ,args function ,@body) - ;; (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) - ;; `(progn - ;; (defun ,helper ,args ,@body) - ;; (elisp-scope-define-analyzer ,fsym (l f &rest args) - ;; (elisp-scope-report-s f 'function) - ;; (apply #',helper args) - ;; (elisp-scope-n l args)))) - ) - -(defmacro elisp-scope-define-func-analyzer (fsym args &rest body) - (declare (indent defun)) - (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) - `(progn - (defun ,helper ,args ,@body) - (elisp-scope-define-analyzer ,fsym (f &rest args) - (elisp-scope-report-s f 'function) - (apply #',helper args))))) + `(elisp-scope--define-function-analyzer ,fsym ,args function ,@body)) (defmacro elisp-scope-define-macro-analyzer (fsym args &rest body) (declare (indent defun)) @@ -1696,45 +1678,46 @@ trusted code macro expansion is always safe." (elisp-scope-1 form)) (elisp-scope-1 lexical)) -(elisp-scope-define-func-analyzer funcall (&optional f &rest args) +(elisp-scope-define-function-analyzer funcall (&optional f &rest args) (elisp-scope-1 f '(symbol . function)) - (dolist (arg args) (elisp-scope-1 arg))) + (elisp-scope-n args)) (put 'apply 'elisp-scope-analyzer #'elisp-scope--analyze-funcall) -(elisp-scope-define-func-analyzer defalias (&optional sym def docstring) +(elisp-scope-define-function-analyzer defalias (&optional sym def docstring) (elisp-scope-1 sym '(symbol . defun)) (elisp-scope-1 def '(symbol . defun)) (elisp-scope-1 docstring)) (elisp-scope-define-function-analyzer oclosure--define - (&optional name _docstring parent-names _slots &rest props) - (when-let* ((quoted (elisp-scope--unquote name))) (elisp-scope-report-s quoted 'defoclosure)) - (when-let* ((qs (elisp-scope--unquote parent-names))) - (dolist (q qs) - (elisp-scope-report-s q 'oclosure))) + (&optional name docstring parent-names slots &rest props) + (elisp-scope-1 name '(symbol . defoclosure)) + (elisp-scope-1 docstring) + (elisp-scope-1 parent-names '(repeat . (symbol . oclosure))) + (elisp-scope-1 slots) ;TODO: Specify type of `slots'. (while-let ((kw (car-safe props)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) (elisp-scope-report-s kw 'constant) - (cl-case bkw - (:predicate - (when-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-report-s q 'defun)))) - (setq props (cddr props)))) + (elisp-scope-1 (cadr props) (when (eq bkw :predicate) '(symbol . defun))) + (setq props (cddr props))) + (when props (elisp-scope-n props))) (elisp-scope-define-function-analyzer define-charset - (&optional name _docstring &rest _props) - (when-let* ((quoted (elisp-scope--unquote name))) (elisp-scope-report-s quoted 'defcharset))) + (&optional name docstring &rest props) + (elisp-scope-1 name '(symbol . defcharset)) + (elisp-scope-1 docstring) + (elisp-scope-n props)) (elisp-scope-define-function-analyzer define-charset-alias (&optional alias charset) - (when-let* ((quoted (elisp-scope--unquote alias))) (elisp-scope-report-s quoted 'defcharset)) - (when-let* ((quoted (elisp-scope--unquote charset))) (elisp-scope-report-s quoted 'charset))) + (elisp-scope-1 alias '(symbol . defcharset)) + (elisp-scope-1 charset '(symbol . charset))) -(elisp-scope-define-func-analyzer charset-chars +(elisp-scope-define-function-analyzer charset-chars (&optional charset &rest rest) (elisp-scope-1 charset '(symbol . charset)) - (mapc #'elisp-scope-1 rest)) + (elisp-scope-n rest)) (dolist (sym '(charset-description charset-info charset-iso-final-char charset-long-name charset-plist @@ -1747,32 +1730,38 @@ trusted code macro expansion is always safe." locale-charset-to-coding-system)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-charset-chars)) -(elisp-scope-define-func-analyzer define-coding-system +(elisp-scope-define-function-analyzer define-coding-system (&optional name &rest rest) (elisp-scope-1 name '(symbol . defcoding)) (mapc #'elisp-scope-1 rest)) -(elisp-scope-define-func-analyzer define-coding-system-alias +(elisp-scope-define-function-analyzer define-coding-system-alias (&optional alias coding-system) (elisp-scope-1 alias '(symbol . defcoding)) (elisp-scope-1 coding-system '(symbol . coding))) (elisp-scope-define-function-analyzer decode-coding-region - (&optional _start _end coding-system &rest _) - (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-scope-report-s quoted 'coding))) + (&optional start end coding-system &rest rest) + (elisp-scope-1 start) + (elisp-scope-1 end) + (elisp-scope-1 coding-system '(symbol . coding)) + (elisp-scope-n rest)) (put 'encode-coding-region 'elisp-scope-analyzer #'elisp-scope--analyze-decode-coding-region) (elisp-scope-define-function-analyzer decode-coding-string - (&optional _string coding-system &rest _) - (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-scope-report-s quoted 'coding))) + (&optional string coding-system &rest rest) + (elisp-scope-1 string) + (elisp-scope-1 coding-system '(symbol . coding)) + (elisp-scope-n rest)) (dolist (sym '(encode-coding-char encode-coding-string)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-decode-coding-string)) (elisp-scope-define-function-analyzer coding-system-mnemonic - (&optional coding-system &rest _) - (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-scope-report-s quoted 'coding))) + (&optional coding-system &rest rest) + (elisp-scope-1 coding-system '(symbol . coding)) + (elisp-scope-n rest)) (dolist (sym '(add-to-coding-system-list check-coding-system @@ -1810,7 +1799,7 @@ trusted code macro expansion is always safe." universal-coding-system-argument)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-coding-system-mnemonic)) -(elisp-scope-define-func-analyzer thing-at-point (&optional thing no-props) +(elisp-scope-define-function-analyzer thing-at-point (&optional thing no-props) (elisp-scope-1 thing '(symbol . thing)) (elisp-scope-1 no-props)) @@ -1820,48 +1809,60 @@ trusted code macro expansion is always safe." bounds-of-thing-at-point)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-thing-at-point)) -(elisp-scope-define-func-analyzer bounds-of-thing-at-mouse (&optional event thing) +(elisp-scope-define-function-analyzer bounds-of-thing-at-mouse (&optional event thing) (elisp-scope-1 event) (elisp-scope-1 thing '(symbol . thing))) -(elisp-scope-define-func-analyzer thing-at-mouse (&optional event thing no-props) +(elisp-scope-define-function-analyzer thing-at-mouse (&optional event thing no-props) (elisp-scope-1 event) (elisp-scope-1 thing '(symbol . thing)) (elisp-scope-1 no-props)) -(elisp-scope-define-function-analyzer custom-declare-variable (sym _default _doc &rest args) - (when-let* ((quoted (elisp-scope--unquote sym))) (elisp-scope-report-s quoted 'defvar)) +(elisp-scope-define-function-analyzer custom-declare-variable (sym default doc &rest args) + (elisp-scope-1 sym '(symbol . defvar)) + (elisp-scope-1 default) + (elisp-scope-1 doc) (while-let ((kw (car-safe args)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) (cl-case bkw (:type - (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-widget-type-1 quoted))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (if-let* ((quoted (elisp-scope--unquote (cadr args)))) + (elisp-scope-widget-type-1 quoted) + (elisp-scope-1 (cadr args)))) (:group - (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s quoted 'group)))) - (setq args (cddr args)))) - -(elisp-scope-define-function-analyzer custom-declare-group (sym _members _doc &rest args) - (when-let* ((quoted (elisp-scope--unquote sym))) (elisp-scope-report-s quoted 'defgroup)) + (elisp-scope-1 (cadr args) '(symbol . group))) + (otherwise (elisp-scope-1 (cadr args)))) + (setq args (cddr args))) + (when args (elisp-scope-n args))) + +(elisp-scope-define-function-analyzer custom-declare-group (sym members doc &rest args) + (elisp-scope-1 sym '(symbol . defgroup)) + (elisp-scope-1 members) + (elisp-scope-1 doc '(symbol . defgroup)) (while-let ((kw (car-safe args)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw - (:group - (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s quoted 'group)))) - (setq args (cddr args)))) + (elisp-scope-report-s kw 'constant) + (elisp-scope-1 (cadr args) (when (eq bkw :group) '(symbol . group))) + (setq args (cddr args))) + (when args (elisp-scope-n args))) -(elisp-scope-define-function-analyzer custom-declare-face (face spec _doc &rest args) - (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-report-s q 'defface)) +(elisp-scope-define-function-analyzer custom-declare-face (face spec doc &rest args) + (elisp-scope-1 face '(symbol . defface)) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. (when-let* ((q (elisp-scope--unquote spec))) (when (consp q) (dolist (s q) (elisp-scope-face (cdr s))))) + (elisp-scope-1 doc) (while-let ((kw (car-safe args)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw - (:group - (when-let* ((q (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s q 'group)))) - (setq args (cddr args)))) + (elisp-scope-report-s kw 'constant) + (elisp-scope-1 (cadr args) (when (eq bkw :group) '(symbol . group))) + (setq args (cddr args))) + (when args (elisp-scope-n args))) (defun elisp-scope-typep (type) (cond @@ -1875,46 +1876,58 @@ trusted code macro expansion is always safe." ((eq (elisp-scope-sym-bare (car type)) 'satisfies) (elisp-scope-report-s (cadr type) 'function)))))) -(elisp-scope-define-function-analyzer cl-typep (_val type) +(elisp-scope-define-function-analyzer cl-typep (val type) + (elisp-scope-1 val) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. (when-let* ((q (elisp-scope--unquote type))) (elisp-scope-typep q))) -(elisp-scope-define-function-analyzer pulse-momentary-highlight-region (_start _end &optional face) - (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-face q))) +(elisp-scope-define-function-analyzer pulse-momentary-highlight-region (start end &optional face) + (elisp-scope-1 start) + (elisp-scope-1 end) + (elisp-scope-1 face '(symbol . face))) -(elisp-scope--define-function-analyzer throw (tag _value) non-local-exit - (when-let* ((q (elisp-scope--unquote tag))) (elisp-scope-report-s q 'throw-tag))) +(elisp-scope--define-function-analyzer throw (&optional tag val) non-local-exit + (elisp-scope-1 tag '(symbol . throw-tag)) + (elisp-scope-1 val)) + +(elisp-scope--define-function-analyzer signal (&optional error-symbol data) non-local-exit + (elisp-scope-1 error-symbol '(symbol . condition)) + (elisp-scope-1 data)) -(elisp-scope--define-function-analyzer signal (error-symbol &optional _data) non-local-exit - (when-let* ((q (elisp-scope--unquote error-symbol))) (elisp-scope-report-s q 'condition))) +(elisp-scope--define-function-analyzer kill-emacs (&rest rest) non-local-exit + (elisp-scope-n rest)) -(elisp-scope--define-function-analyzer kill-emacs (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer abort-recursive-edit (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer top-level (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer exit-recursive-edit (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer tty-frame-restack (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer error (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer user-error (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer minibuffer-quit-recursive-edit (&rest _) non-local-exit) -(elisp-scope--define-function-analyzer exit-minibuffer (&rest _) non-local-exit) +(dolist (sym '( abort-recursive-edit top-level exit-recursive-edit + tty-frame-restack error user-error + minibuffer-quit-recursive-edit exit-minibuffer)) + (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-kill-emacs)) -(elisp-scope-define-func-analyzer run-hooks (&rest hooks) +(elisp-scope-define-function-analyzer run-hooks (&rest hooks) (dolist (hook hooks) (elisp-scope-1 hook '(symbol . variable)))) -(elisp-scope-define-func-analyzer fboundp (&optional symbol) +(elisp-scope-define-function-analyzer fboundp (&optional symbol) (elisp-scope-1 symbol '(symbol . function))) -(elisp-scope-define-function-analyzer overlay-put (&optional _ov prop val) - (when-let* ((q (elisp-scope--unquote prop)) - ((eq (elisp-scope-sym-bare q) 'face)) - (face (elisp-scope--unquote val))) - (elisp-scope-face face))) - -(elisp-scope-define-function-analyzer add-face-text-property (&optional _start _end face &rest _) - (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-face q))) +(elisp-scope-define-function-analyzer overlay-put (&optional ov prop val) + (elisp-scope-1 ov) + (elisp-scope-1 prop) ;TODO: Recognize overlay props. + (if-let* ((q (elisp-scope--unquote prop)) + ((eq (elisp-scope-sym-bare q) 'face)) + (face (elisp-scope--unquote val))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (elisp-scope-face face) + (elisp-scope-1 val))) + +(elisp-scope-define-function-analyzer add-face-text-property (&optional start end face &rest rest) + (elisp-scope-1 start) + (elisp-scope-1 end) + (elisp-scope-1 face '(symbol . face)) + (elisp-scope-n rest)) -(elisp-scope-define-function-analyzer facep (&optional face &rest _) - (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-report-s q 'face))) +(elisp-scope-define-function-analyzer facep (&optional face &rest rest) + (elisp-scope-1 face '(symbol . face)) + (elisp-scope-n rest)) (dolist (sym '( check-face face-id face-differs-from-default-p face-name face-all-attributes face-attribute @@ -1927,9 +1940,9 @@ trusted code macro expansion is always safe." set-face-bold set-face-italic set-face-extend)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-facep)) -(elisp-scope-define-func-analyzer boundp (&optional var &rest rest) +(elisp-scope-define-function-analyzer boundp (&optional var &rest rest) (elisp-scope-1 var '(symbol . variable)) - (mapc #'elisp-scope-1 rest)) + (elisp-scope-n rest)) (dolist (sym '( set symbol-value define-abbrev-table special-variable-p local-variable-p @@ -1941,141 +1954,187 @@ trusted code macro expansion is always safe." add-hook remove-hook run-hook-with-args run-hook-wrapped)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-boundp)) -(elisp-scope-define-function-analyzer defvaralias (new base &optional _docstring) - (when-let* ((q (elisp-scope--unquote new))) (elisp-scope-report-s q 'defvar)) - (when-let* ((q (elisp-scope--unquote base))) (elisp-scope-report-s q 'variable))) +(elisp-scope-define-function-analyzer defvaralias (new base &optional docstring) + (elisp-scope-1 new '(symbol . defvar)) + (elisp-scope-1 base '(symbol . variable)) + (elisp-scope-1 docstring)) -(elisp-scope-define-func-analyzer define-error (&optional name message parent) +(elisp-scope-define-function-analyzer define-error (&optional name message parent) (elisp-scope-1 name '(symbol . defcondition)) (elisp-scope-1 message) (elisp-scope-1 parent '(or (symbol . condition) - (repeat . (symbol . condition))))) + (repeat . (symbol . condition))))) -(elisp-scope-define-function-analyzer featurep (feature &rest _) - (when-let* ((q (elisp-scope--unquote feature))) (elisp-scope-report-s q 'feature))) +(elisp-scope-define-function-analyzer featurep (feature &rest rest) + (elisp-scope-1 feature '(symbol . feature)) + (elisp-scope-n rest)) (put 'require 'elisp-scope-analyzer #'elisp-scope--analyze-featurep) -(elisp-scope-define-function-analyzer provide (feature &rest _) - (when-let* ((q (elisp-scope--unquote feature))) (elisp-scope-report-s q 'deffeature))) +(elisp-scope-define-function-analyzer provide (feature &rest rest) + (elisp-scope-1 feature '(symbol . deffeature)) + (elisp-scope-n rest)) -(elisp-scope-define-function-analyzer put-text-property (&optional _ _ prop val _) - (when (memq (elisp-scope-sym-bare (elisp-scope--unquote prop)) '(mouse-face face)) - (when-let* ((q (elisp-scope--unquote val))) (elisp-scope-face q)))) +(elisp-scope-define-function-analyzer put-text-property (&optional beg end prop val obj) + (elisp-scope-1 beg) + (elisp-scope-1 end) + (elisp-scope-1 prop) + (if-let* (((memq (elisp-scope-sym-bare (elisp-scope--unquote prop)) + '(mouse-face face))) + (q (elisp-scope--unquote val))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (elisp-scope-face q) + (elisp-scope-1 val)) + (elisp-scope-1 obj)) (put 'remove-overlays 'elisp-scope-analyzer #'elisp-scope--analyze-put-text-property) -(elisp-scope-define-function-analyzer propertize (_string &rest props) +(elisp-scope-define-function-analyzer propertize (string &rest props) + (elisp-scope-1 string) (while props + (elisp-scope-1 (car props)) (cl-case (elisp-scope-sym-bare (elisp-scope--unquote (car props))) ((face mouse-face) - (when-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-face q)))) - (setq props (cddr props)))) + (if-let* ((q (elisp-scope--unquote (cadr props)))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (elisp-scope-face q) + (elisp-scope-1 (cadr props)))) + (otherwise (elisp-scope-1 (cadr props)))) + (setq props (cddr props))) + (when props (elisp-scope-n props))) -(elisp-scope-define-function-analyzer eieio-defclass-internal (name superclasses _ _) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftype)) - (when-let* ((q (elisp-scope--unquote superclasses))) - (dolist (sup q) (elisp-scope-report-s sup 'type)))) +(elisp-scope-define-function-analyzer eieio-defclass-internal + (&optional name superclasses slots options) + (elisp-scope-1 name '(symbol . deftype)) + (elisp-scope-1 superclasses '(repeat . (symbol . type))) + (elisp-scope-1 slots) ;TODO: Specify type of `slots'. + (elisp-scope-1 options)) (elisp-scope-define-function-analyzer cl-struct-define - (name _doc parent _type _named _slots _children _tab _print) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftype)) - (when-let* ((q (elisp-scope--unquote parent))) (elisp-scope-report-s q 'type))) - -(elisp-scope-define-function-analyzer define-widget (name class _doc &rest args) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'widget-type)) - (when-let* ((q (elisp-scope--unquote class))) (elisp-scope-report-s q 'widget-type)) + (&optional name doc parent type named slots children tag print) + (elisp-scope-1 name '(symbol . deftype)) + (elisp-scope-1 doc) + (elisp-scope-1 parent '(symbol . type)) + (elisp-scope-1 type) + (elisp-scope-1 named) + (elisp-scope-1 slots) ;TODO: Specify type of `slots'. + (elisp-scope-1 children) + (elisp-scope-1 tag) + (elisp-scope-1 print)) + +(elisp-scope-define-function-analyzer define-widget (name class doc &rest args) + (elisp-scope-1 name '(symbol . widget-type-definition)) + (elisp-scope-1 class '(symbol . widget-type)) + (elisp-scope-1 doc) (while-let ((kw (car-safe args)) (bkw (elisp-scope-sym-bare kw)) ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) (cl-case bkw (:type - (when-let* ((q (elisp-scope--unquote (cadr args)))) (elisp-scope-widget-type-1 q))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (if-let* ((quoted (elisp-scope--unquote (cadr args)))) + (elisp-scope-widget-type-1 quoted) + (elisp-scope-1 (cadr args)))) (:args - (when-let* ((q (elisp-scope--unquote (cadr args)))) (mapc #'elisp-scope-widget-type-1 q)))) - (setq args (cddr args)))) - -(elisp-scope-define-function-analyzer provide-theme (name &rest _) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'theme))) + (if-let* ((quoted (elisp-scope--unquote (cadr args)))) + (mapc #'elisp-scope-widget-type-1 quoted) + (elisp-scope-1 (cadr args)))) + (otherwise (elisp-scope-1 (cadr args)))) + (setq args (cddr args))) + (when args (elisp-scope-n args))) + +(elisp-scope-define-function-analyzer provide-theme (name &rest rest) + (elisp-scope-1 name '(symbol . theme)) + (elisp-scope-n rest)) (dolist (sym '(enable-theme disable-theme load-theme custom-theme-p)) (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-provide-theme)) (elisp-scope-define-function-analyzer custom-theme-set-variables (theme &rest args) - (when-let* ((q (elisp-scope--unquote theme))) (elisp-scope-report-s q 'theme)) + (elisp-scope-1 theme '(symbol . theme)) (dolist (arg args) - (when-let* ((q (elisp-scope--unquote arg))) - (when (consp q) - (elisp-scope-report-s (pop q) 'variable) - (when (consp q) - (elisp-scope-1 (pop q)) - (dolist (request (car (cdr-safe q))) - (elisp-scope-report-s request 'feature))))))) - -(elisp-scope-define-function-analyzer custom-declare-theme (name &rest _) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftheme))) + (elisp-scope-1 + arg + '(cons (symbol . variable) . + (cons code . + (or (cons t . + (cons (repeat . (symbol . feature)) . + t)) + t)))))) + +(elisp-scope-define-function-analyzer custom-declare-theme (name &rest rest) + (elisp-scope-1 name '(symbol . deftheme)) + (elisp-scope-n rest)) -(elisp-scope-define-function-analyzer eieio-oref (_obj slot) - (when-let* ((q (elisp-scope--unquote slot))) (elisp-scope-report-s q 'slot))) +(elisp-scope-define-function-analyzer eieio-oref (obj slot) + (elisp-scope-1 obj) + (elisp-scope-1 slot '(symbol . slot))) (dolist (fun '(slot-boundp slot-makeunbound slot-exists-p eieio-oref-default)) (put fun 'elisp-scope-analyzer #'elisp-scope--analyze-eieio-oref)) -(elisp-scope-define-function-analyzer eieio-oset (_obj slot _value) - (when-let* ((q (elisp-scope--unquote slot))) (elisp-scope-report-s q 'slot))) +(elisp-scope-define-function-analyzer eieio-oset (obj slot value) + (elisp-scope-1 obj) + (elisp-scope-1 slot '(symbol . slot)) + (elisp-scope-1 value)) (put 'eieio-oset-default 'elisp-scope-analyzer #'elisp-scope--analyze-eieio-oset) -(elisp-scope-define-function-analyzer derived-mode-p (modes &rest _obsolete) - (when-let* ((q (elisp-scope--unquote modes))) (elisp-scope-report-s q 'major-mode))) +(elisp-scope-define-function-analyzer derived-mode-p (modes &rest rest) + (elisp-scope-1 modes '(or (repeat . (symbol . major-mode)) + (symbol . major-mode))) + (dolist (mode rest) (elisp-scope-1 mode '(symbol . major-mode)))) -(elisp-scope-define-func-analyzer derived-mode-set-parent (&optional mode parent) +(elisp-scope-define-function-analyzer derived-mode-set-parent (&optional mode parent) (elisp-scope-1 mode '(symbol . major-mode)) (elisp-scope-1 parent '(symbol . major-mode))) -(elisp-scope-define-func-analyzer elisp-scope-report (type &rest args) +(elisp-scope-define-function-analyzer elisp-scope-report (type &rest args) (elisp-scope-1 type '(symbol . symbol-type)) (mapc #'elisp-scope-1 args)) -(elisp-scope-define-func-analyzer elisp-scope-report-s (&optional sym type) +(elisp-scope-define-function-analyzer elisp-scope-report-s (&optional sym type) (elisp-scope-1 sym) (elisp-scope-1 type '(symbol . symbol-type))) -(elisp-scope-define-func-analyzer elisp-scope-1 (&optional form outtype) +(elisp-scope-define-function-analyzer elisp-scope-1 (&optional form outtype) (elisp-scope-1 form) (elisp-scope-1 outtype 'type)) -(elisp-scope-define-function-analyzer icons--register (&optional name parent _spec _doc kws) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deficon)) - (when-let* ((q (elisp-scope--unquote parent))) (elisp-scope-report-s q 'icon)) - (when-let* ((q (elisp-scope--unquote kws))) - (while-let ((kw (car-safe q)) - (bkw (elisp-scope-sym-bare kw)) - ((keywordp bkw))) - (elisp-scope-report-s kw 'constant) - (cl-case bkw - (:group (elisp-scope-report-s (cadr q) 'group))) - (setq q (cddr q))))) - -(elisp-scope-define-function-analyzer setopt--set (&optional var _val) - (when-let* ((q (elisp-scope--unquote var))) (elisp-scope-report-s q 'variable))) - -(elisp-scope-define-function-analyzer autoload (&optional func _file _doc int &rest _) - (when-let* ((q (elisp-scope--unquote func))) (elisp-scope-report-s q 'function)) - (when-let* ((q (elisp-scope--unquote int)) ((listp q))) - (dolist (mode q) (elisp-scope-report-s mode 'major-mode)))) - -(elisp-scope-define-function-analyzer minibuffer--define-completion-category (&optional name parents &rest _) - (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'completion-category-definition)) - (when-let* ((q (elisp-scope--unquote parents))) - (dolist (p (ensure-list q)) (elisp-scope-report-s p 'completion-category)))) +(elisp-scope-define-function-analyzer icons--register (&optional name parent spec doc kws) + (elisp-scope-1 name '(symbol . deficon)) + (elisp-scope-1 parent '(symbol . icon)) + (elisp-scope-1 spec) ;TODO: Specify type of `spec'. + (elisp-scope-1 doc) + (if-let* ((q (elisp-scope--unquote kws))) + (progn + (while-let ((kw (car-safe q)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (elisp-scope-1 (cadr q) (when (eq bkw :group) '(symbol . group))) + (setq q (cddr q))) + (when q (elisp-scope-n q))) + (elisp-scope-1 kws))) -;; (elisp-scope-define-macro-analyzer define-completion-category (l &optional name parent &rest rest) -;; (elisp-scope-report-s name 'completion-category-definition) -;; (elisp-scope-report-s parent 'completion-category) -;; (elisp-scope-n l rest)) +(elisp-scope-define-function-analyzer setopt--set (&optional var val) + (elisp-scope-1 var '(symbol . variable)) + (elisp-scope-1 val elisp-scope--output-type)) + +(elisp-scope-define-function-analyzer autoload (&optional func file doc int type) + (elisp-scope-1 func '(symbol . function)) + (elisp-scope-1 file) + (elisp-scope-1 doc) + (elisp-scope-1 int '(repeat . (symbol . major-mode))) + (elisp-scope-1 type)) + +(elisp-scope-define-function-analyzer minibuffer--define-completion-category (&optional name parents &rest rest) + (elisp-scope-1 name '(symbol . completion-category-definition)) + (elisp-scope-1 parents '(repeat . (symbol . completion-category))) + (elisp-scope-n rest)) -(elisp-scope-define-func-analyzer completion-table-with-category (&optional category table) +(elisp-scope-define-function-analyzer completion-table-with-category (&optional category table) (elisp-scope-1 category '(symbol . completion-category)) (elisp-scope-1 table)) @@ -2105,30 +2164,40 @@ trusted code macro expansion is always safe." (setq it (cddr it)))))) ((consp item) (elisp-scope--easy-menu-do-define-menu item)))))) -(elisp-scope-define-function-analyzer easy-menu-do-define (&optional _symbol _maps _doc menu) - (when-let* ((q (elisp-scope--unquote menu))) - (elisp-scope--easy-menu-do-define-menu q))) - -(elisp-scope-define-function-analyzer define-key (&optional _keymaps _key def _remove) - (when-let* ((q (elisp-scope--unquote def))) - (cond - ((eq (elisp-scope-sym-bare (car-safe q)) 'menu-item) - (let ((fn (caddr q)) (it (cdddr q))) - (elisp-scope-sharpquote fn) - (while-let ((kw (car-safe it)) - (bkw (elisp-scope-sym-bare kw)) - ((keywordp bkw))) - (elisp-scope-report-s kw 'constant) - (cl-case bkw - ((:active :enable :label :visible :suffix :selected) (elisp-scope-1 (cadr it))) - ((:filter) (elisp-scope-sharpquote (cadr it)))) - (setq it (cddr it))))) - ((or (symbolp q) (symbol-with-pos-p q)) - (elisp-scope-report-s q 'function))))) +(elisp-scope-define-function-analyzer easy-menu-do-define (&optional symbol maps doc menu) + (elisp-scope-1 symbol) + (elisp-scope-1 maps) + (elisp-scope-1 doc) + (if-let* ((q (elisp-scope--unquote menu))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (elisp-scope--easy-menu-do-define-menu q) + (elisp-scope-1 menu))) + +(elisp-scope-define-function-analyzer define-key (&optional keymap key def remove) + (elisp-scope-1 keymap) + (elisp-scope-1 key) + (if-let* ((q (elisp-scope--unquote def))) + ;; TODO: Use `elisp-scope-1' with an appropriate outtype. + (cond + ((eq (elisp-scope-sym-bare (car-safe q)) 'menu-item) + (let ((fn (caddr q)) (it (cdddr q))) + (elisp-scope-sharpquote fn) + (while-let ((kw (car-safe it)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + ((:active :enable :label :visible :suffix :selected) (elisp-scope-1 (cadr it))) + ((:filter) (elisp-scope-sharpquote (cadr it)))) + (setq it (cddr it))))) + ((or (symbolp q) (symbol-with-pos-p q)) + (elisp-scope-report-s q 'function))) + (elisp-scope-1 def)) + (elisp-scope-1 remove)) (elisp-scope-define-function-analyzer eval-after-load (&optional file form) - (when-let* ((q (elisp-scope--unquote file))) (elisp-scope-report-s q 'feature)) - (when-let* ((q (elisp-scope--unquote form))) (elisp-scope-1 q))) + (elisp-scope-1 file '(symbol . feature)) + (elisp-scope-1 form 'code)) (elisp-scope-define-macro-analyzer define-globalized-minor-mode (global mode turn-on &rest body) (elisp-scope-report-s mode 'function) @@ -2520,12 +2589,15 @@ trusted code macro expansion is always safe." (cl-defgeneric elisp-scope--match-type-to-arg (type arg)) +(cl-defmethod elisp-scope--match-type-to-arg ((type (eql t)) _arg) type) + (cl-defmethod elisp-scope--match-type-to-arg ((type (eql 'code)) _arg) type) (cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'type)) arg) (elisp-scope--match-type-to-arg ;; Unfold `type'. - '(or (equal . code) + '(or (equal . t) + (equal . code) (equal . type) (cons (equal . symbol) . (symbol . symbol-type)) (cons (equal . repeat) . type) @@ -2560,12 +2632,7 @@ trusted code macro expansion is always safe." (cons 'cons (cons car-res cdr-res)))))) (cl-defmethod elisp-scope--match-type-to-arg ((type (head equal)) arg) - (equal (cdr type) arg)) - -(elisp-scope--match-type-to-arg '(repeat . - (or (cons (equal . foo) . (symbol footype)) - (cons (equal . bar) . (symbol bartype)))) - '((bar . spambar) (foo . spamfoo))) + (let ((symbols-with-pos-enabled t)) (equal (cdr type) arg))) (elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) (elisp-scope-1 tag '(symbol . throw-tag)) @@ -2617,7 +2684,7 @@ trusted code macro expansion is always safe." ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) ((macrop bare) (elisp-scope-report-s f 'macro) (cond - ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)) + ;; ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)) ((elisp-scope-safe-macro-p bare) (let* ((warning-minimum-log-level :emergency) (macroexp-inhibit-compiler-macros t) @@ -2627,7 +2694,7 @@ trusted code macro expansion is always safe." (macroexpand-all-environment (append (mapcar #'list elisp-scope-unsafe-macros) macroexpand-all-environment)) (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) - (elisp-scope-1 expanded))))) + (elisp-scope-1 expanded outtype))))) ((or (functionp bare) (memq bare elisp-scope-local-functions)) (elisp-scope-report-s f 'function) (elisp-scope-n forms)) (t commit c6ee775cb29214c40b7e13ef39e5b80855f64200 Author: Eshel Yaron Date: Mon Sep 29 17:02:25 2025 +0200 ; Rename scope.el to elisp-scope.el * scope.el: Rename it to... * elisp-scope: New file. * lisp/progmodes/elisp-mode.el: Update accordingly. diff --git a/lisp/emacs-lisp/elisp-scope.el b/lisp/emacs-lisp/elisp-scope.el new file mode 100644 index 00000000000..74f7fd93ae3 --- /dev/null +++ b/lisp/emacs-lisp/elisp-scope.el @@ -0,0 +1,2667 @@ +;;; elisp-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 `elisp-scope-analyze-form', see its docstring for usage +;; information. + +;;; Code: + +(require 'cl-lib) + +(defvar elisp-scope--symbol-type-property-cache (make-hash-table)) + +(defun elisp-scope--define-symbol-type (name parents props) + (clrhash elisp-scope--symbol-type-property-cache) + (put name 'elisp-scope-parent-types parents) + (put name 'elisp-scope-type-properties props)) + +;;;###autoload +(defmacro elisp-scope-define-symbol-type (name parents &rest props) + (declare (indent defun)) + `(elisp-scope--define-symbol-type ',name ',parents ,(when props `(list ,@props)))) + +;;;###autoload +(defun elisp-scope-get-symbol-type-property (type prop) + (with-memoization (alist-get prop (gethash type elisp-scope--symbol-type-property-cache)) + (named-let loop ((current type) + (parents (get type 'elisp-scope-parent-types)) + (more nil) + (done nil)) + (or (plist-get (get current 'elisp-scope-type-properties) prop) + (when-let* ((next (car parents))) + (loop (car parents) (get next 'elisp-scope-parent-types) (append (cdr parents) more) done)) + (when-let* ((next (car more))) + (loop next (let (res) + (dolist (per (get next 'elisp-scope-parent-types)) + (unless (memq per done) + (push per res))) + (nreverse res)) + (cdr more) done)))))) + +;;;###autoload +(defun elisp-scope-set-symbol-type-property (type prop value) + (clrhash elisp-scope--symbol-type-property-cache) + (put type 'elisp-scope-type-properties + (plist-put (get type 'elisp-scope-type-properties) prop value))) + +;;;###autoload +(defun elisp-scope-symbol-type-p (sym) + (or (get sym 'elisp-scope-parent-types) (get sym 'elisp-scope-type-properties))) + +(defvar elisp-scope-read-symbol-type-history nil) + +(defun elisp-scope-read-symbol-type (prompt &optional default) + (completing-read + (format-prompt prompt default) + obarray #'elisp-scope-symbol-type-p 'confirm + nil 'elisp-scope-read-symbol-type-history default)) + +(defvar help-mode--current-data) + +;;;###autoload +(defun elisp-scope-describe-symbol-type (type) + (interactive (list (elisp-scope-read-symbol-type + "Describe symbol type" + (when-let* ((def (symbol-at-point)) + ((elisp-scope-symbol-type-p def))) + def)))) + (when (stringp type) (setq type (intern type))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'elisp-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 (elisp-scope-get-symbol-type-property type :doc) + "Undocumented."))) + (when-let* ((parents (get type 'elisp-scope-parent-types))) + (insert "\n\nParent types: " + (mapconcat (lambda (parent) + (let ((name (symbol-name parent))) + (substitute-quotes + (concat + "`" + (buttonize + name #'elisp-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))))))) + +(elisp-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) + +(elisp-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) + +(elisp-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) + +(elisp-scope-define-symbol-type bound-variable (variable) + :doc "Local variable names." + :face 'elisp-bound-variable + :help (cl-constantly "Local variable")) + +(elisp-scope-define-symbol-type binding-variable (bound-variable) + :doc "Local variable definitions." + :face 'elisp-binding-variable + :help (cl-constantly "Local variable binding")) + +(elisp-scope-define-symbol-type shadowed-variable (variable) + :doc "Locally shadowed variable names." + :face 'elisp-shadowed-variable + :help (cl-constantly "Locally shadowed variable")) + +(elisp-scope-define-symbol-type shadowing-variable (shadowed-variable) + :doc "Local variable definitions." + :face 'elisp-shadowing-variable + :help (cl-constantly "Local variable shadowing")) + +(elisp-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) + +(elisp-scope-define-symbol-type callable () + :doc "Abstract symbol type of function-like symbols." + :namespace 'function) + +(elisp-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"))))) + +(elisp-scope-define-symbol-type command (function) + :doc "Command names.") + +(elisp-scope-define-symbol-type unknown (function) + :doc "Unknown symbols at function position." + :face 'elisp-unknown-call + :help (cl-constantly "Unknown callable")) + +(elisp-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"))) + +(elisp-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"))) + +(elisp-scope-define-symbol-type undefined-macro (macro) + :doc "Known macro names whose definition is unknown." + :help (cl-constantly "Call to macro with unknown definition")) + +(elisp-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"))) + +(elisp-scope-define-symbol-type throw-tag () + :doc "Symbols used as `throw'/`catch' tags." + :face 'elisp-throw-tag + :help (cl-constantly "`throw'/`catch' tag")) + +(elisp-scope-define-symbol-type warning-type () + :doc "Byte-compilation warning types." + :face 'elisp-warning-type + :help (cl-constantly "Warning type")) + +(elisp-scope-define-symbol-type feature () + :doc "Feature names." + :definition 'deffeature + :face 'elisp-feature + :help (cl-constantly "Feature") + :namespace 'feature) + +(elisp-scope-define-symbol-type deffeature (feature) + :doc "Feature definitions." + :imenu "Feature" + :help (cl-constantly "Feature definition")) + +(elisp-scope-define-symbol-type declaration () + :doc "Function attribute declaration types." + :face 'elisp-declaration + :help (cl-constantly "Declaration")) + +(elisp-scope-define-symbol-type rx-construct () + :doc "`rx' constructs." + :face 'elisp-rx + :help (cl-constantly "`rx' construct")) + +(elisp-scope-define-symbol-type theme () + :doc "Custom theme names." + :definition 'deftheme + :face 'elisp-theme + :help (cl-constantly "Theme")) + +(elisp-scope-define-symbol-type deftheme (theme) + :doc "Custom theme definitions." + :imenu "Theme" + :help (cl-constantly "Theme definition")) + +(elisp-scope-define-symbol-type thing () + :doc "`thing-at-point' \"thing\" identifiers." + :face 'elisp-thing + :help (cl-constantly "Thing (text object)")) + +(elisp-scope-define-symbol-type slot () + :doc "EIEIO slots." + :face 'elisp-slot + :help (cl-constantly "Slot")) + +(elisp-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) + +(elisp-scope-define-symbol-type widget-type-definition (widget-type) + :doc "Widget type definitions." + :imenu "Widget" + :help (cl-constantly "Widget type definition")) + +(elisp-scope-define-symbol-type type () + :doc "ELisp object type names." + :face 'elisp-type + :help (cl-constantly "Type")) + +(elisp-scope-define-symbol-type deftype (type) + :doc "ELisp object type definitions." + :imenu "Type" + :help (cl-constantly "Type definition")) + +(elisp-scope-define-symbol-type group () + :doc "Customization groups." + :definition 'defgroup + :face 'elisp-group + :help (cl-constantly "Customization group")) + +(elisp-scope-define-symbol-type defgroup (group) + :doc "Customization group definitions." + :imenu "Group" + :help (cl-constantly "Customization group definition")) + +(elisp-scope-define-symbol-type nnoo-backend () + :doc "`nnoo' backend names." + :face 'elisp-nnoo-backend + :help (cl-constantly "`nnoo' backend")) + +(elisp-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) + +(elisp-scope-define-symbol-type defcondition (condition) + :doc "`condition-case' condition definitions." + :definition 'defcondition + :help (cl-constantly "`condition-case' condition definition")) + +(elisp-scope-define-symbol-type ampersand () + :doc "Argument list markers, such as `&optional' and `&rest'." + :face 'elisp-ampersand + :help (cl-constantly "Arguments separator")) + +(elisp-scope-define-symbol-type constant () + :doc "Self-evaluating symbols." + :face 'elisp-constant + :help (cl-constantly "Constant")) + +(elisp-scope-define-symbol-type defun () + :doc "Function definitions." + :definition 'defun + :face 'elisp-defun + :help (cl-constantly "Function definition") + :imenu "Function" + :namespace 'function) + +(elisp-scope-define-symbol-type defmacro () + :doc "Macro definitions." + :definition 'defmacro + :face 'elisp-defmacro + :help (cl-constantly "Macro definition") + :imenu "Macro" + :namespace 'function) + +(elisp-scope-define-symbol-type defcmd (defun) + :doc "Command definitions." + :definition 'defcmd + :help (cl-constantly "Command definition") + :imenu "Command") + +(elisp-scope-define-symbol-type defvar () + :doc "Variable definitions." + :definition 'defvar + :face 'elisp-defvar + :help (cl-constantly "Special variable definition") + :imenu "Variable" + :namespace 'variable) + +(elisp-scope-define-symbol-type defface () + :doc "Face definitions." + :definition 'defface + :face 'elisp-defface + :help (cl-constantly "Face definition") + :imenu "Face" + :namespace 'face) + +(elisp-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) + +(elisp-scope-define-symbol-type major-mode-definition (major-mode) + :doc "Major mode definitions." + :help (cl-constantly "Major mode definition") + :imenu "Major Mode") + +(elisp-scope-define-symbol-type block () + :doc "`cl-block' block names." + :help (lambda (beg _end def) + (if (equal beg def) "Block definition" "Block"))) + +(elisp-scope-define-symbol-type icon () + :doc "Icon names." + :definition 'deficon + :face 'elisp-icon + :help (cl-constantly "Icon") + :namespace 'icon) + +(elisp-scope-define-symbol-type deficon () + :doc "Icon definitions." + :definition 'deficon + :face 'elisp-deficon + :help (cl-constantly "Icon definition") + :imenu "Icon" + :namespace 'icon) + +(elisp-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) + +(elisp-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) + +(elisp-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) + +(elisp-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) + +(elisp-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) + +(elisp-scope-define-symbol-type defcharset () + :doc "Charset definitions." + :definition 'defcharset + :face 'elisp-defcharset + :help (cl-constantly "Charset definition") + :imenu "Charset" + :namespace 'charset) + +(elisp-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) + +(elisp-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 elisp-scope-counter nil) + +(defvar elisp-scope-local-functions nil) + +(defvar elisp-scope--local nil) + +(defvar elisp-scope--output-type nil) + +(defvar elisp-scope-callback #'ignore) + +(defvar elisp-scope-current-let-alist-form nil) + +(defvar elisp-scope-gen-id-alist nil) + +(defsubst elisp-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 elisp-scope-counter)))) local)) + +(defsubst elisp-scope-sym-pos (sym) + (when (symbol-with-pos-p sym) (symbol-with-pos-pos sym))) + +(defsubst elisp-scope-sym-bare (sym) + (cond + ((symbolp sym) sym) + ((symbol-with-pos-p sym) (bare-symbol sym)))) + +(defvar elisp-scope--quoted nil) + +(defsubst elisp-scope-report (type beg len &optional id def) + (funcall elisp-scope-callback type beg len id (or def (and (numberp id) id)))) + +(defvar elisp-scope-special-variables nil) + +(defun elisp-scope-special-variable-p (sym) + (or (memq sym elisp-scope-special-variables) (special-variable-p sym))) + +(defun elisp-scope-variable (sym beg len id) + (elisp-scope-report + (if id (if (elisp-scope-special-variable-p sym) 'shadowed-variable 'bound-variable) 'variable) + beg len id)) + +(defun elisp-scope-binding (sym beg len) + (elisp-scope-report + (if (elisp-scope-special-variable-p sym) 'shadowing-variable 'binding-variable) + beg len beg)) + +(defun elisp-scope-s (sym) + (let* ((beg (elisp-scope-sym-pos sym)) + (bare (elisp-scope-sym-bare sym)) + (name (symbol-name bare)) + (len (length name))) + (when (and beg (not (booleanp bare))) + (cond + ((keywordp bare) (elisp-scope-report 'constant beg len)) + ((and elisp-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)))) + (elisp-scope-variable unescaped beg len (alist-get unescaped elisp-scope--local))) + (elisp-scope-report 'bound-variable beg len + (list 'let-alist (car elisp-scope-current-let-alist-form) bare) + (cdr elisp-scope-current-let-alist-form)))) + (t (elisp-scope-variable bare beg len (alist-get bare elisp-scope--local))))))) + +(defun elisp-scope-let-1 (local bindings body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (elisp-scope-sym-bare sym)) + (len (length (symbol-name bare))) + (beg (elisp-scope-sym-pos sym))) + (when beg (elisp-scope-binding bare beg len)) + (elisp-scope-1 (cadr binding)) + (elisp-scope-let-1 (if bare (elisp-scope-local-new bare beg local) local) + (cdr bindings) body)) + (let ((elisp-scope--local local)) + (elisp-scope-n body elisp-scope--output-type)))) + +(defun elisp-scope-let (bindings body) + (elisp-scope-let-1 elisp-scope--local bindings body)) + +(defun elisp-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 (elisp-scope-sym-pos sym))) + (when beg (elisp-scope-binding bare beg len)) + (elisp-scope-1 (cadr binding)) + (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (elisp-scope-let* (cdr bindings) body))) + (elisp-scope-n body elisp-scope--output-type))) + +(defun elisp-scope-interactive (intr spec modes) + (when (symbol-with-pos-p intr) + (elisp-scope-report 'special-form + (symbol-with-pos-pos intr) + (length (symbol-name (elisp-scope-sym-bare intr))))) + (elisp-scope-1 spec) + (mapc #'elisp-scope-major-mode-name modes)) + +(defun elisp-scope-lambda (args body &optional outtype) + (let ((l elisp-scope--local)) + (when (listp args) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (elisp-scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (elisp-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)) + (elisp-scope-s (caar body)) + (elisp-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) + (elisp-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 (elisp-scope-sym-bare head))) + (when (symbol-with-pos-p head) + (elisp-scope-report 'declaration + (symbol-with-pos-pos head) + (length (symbol-name bare)))) + (cl-case bare + (completion (elisp-scope-sharpquote (cadr spec))) + (interactive-only + (when-let* ((bare (elisp-scope-sym-bare (cadr spec))) + ((not (eq bare t)))) + (elisp-scope-sharpquote (cadr spec)))) + (obsolete + (when-let* ((bare (elisp-scope-sym-bare (cadr spec)))) + (elisp-scope-sharpquote (cadr spec)))) + ((compiler-macro gv-expander gv-setter) + ;; Use the extended lexical environment `l'. + (let ((elisp-scope--local l)) + (elisp-scope-sharpquote (cadr spec)))) + (modes (mapc #'elisp-scope-major-mode-name (cdr spec))) + (interactive-args + (dolist (arg-form (cdr spec)) + (when-let* ((arg (car-safe arg-form))) + (let ((elisp-scope--local l)) (elisp-scope-s arg)) + (when (consp (cdr arg-form)) + (elisp-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))) + (elisp-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)) + (elisp-scope-report 'ampersand beg len) + (elisp-scope-report 'binding-variable beg len beg))))))) + ;; Handle BODY. + (let ((elisp-scope--local l)) (elisp-scope-n body outtype)))) + +(defun elisp-scope-defun (name args body) + (when-let* ((beg (elisp-scope-sym-pos name)) + (bare (elisp-scope-sym-bare name))) + (elisp-scope-report + (let ((tmp body)) + (when (stringp (car-safe tmp)) (pop tmp)) + (when (eq 'declare (elisp-scope-sym-bare (car-safe (car-safe tmp)))) (pop tmp)) + (if (eq 'interactive (elisp-scope-sym-bare (car-safe (car-safe tmp)))) + 'defcmd + 'defun)) + beg (length (symbol-name bare)))) + (elisp-scope-lambda args body)) + +(defun elisp-scope-setq (args) (elisp-scope-n args elisp-scope--output-type)) + +(defvar elisp-scope-flet-alist nil) + +(defun elisp-scope-flet (defs body) + (if defs + (let* ((def (car defs)) + (func (car def)) + (exps (cdr def)) + (beg (elisp-scope-sym-pos func)) + (bare (bare-symbol func))) + (when beg + (elisp-scope-report 'function beg (length (symbol-name bare)) beg)) + (if (cdr exps) + ;; def is (FUNC ARGLIST BODY...) + (elisp-scope-cl-lambda (car exps) (cdr exps)) + ;; def is (FUNC EXP) + (elisp-scope-1 (car exps))) + (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) + (elisp-scope-flet (cdr defs) body))) + (elisp-scope-n body))) + +(defun elisp-scope-labels (defs forms) + (if defs + (let* ((def (car defs)) + (func (car def)) + (args (cadr def)) + (body (cddr def)) + (beg (elisp-scope-sym-pos func)) + (bare (bare-symbol func))) + (when beg + (elisp-scope-report 'function beg (length (symbol-name bare)) beg)) + (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist))) + (elisp-scope-lambda args body) + (elisp-scope-flet (cdr defs) forms))) + (elisp-scope-n forms))) + +(defvar elisp-scope-block-alist nil) + +(defun elisp-scope-block (name body) + (if name + (let* ((beg (elisp-scope-sym-pos name)) + (bare (bare-symbol name))) + (when beg + (elisp-scope-report 'block beg (length (symbol-name bare)) beg)) + (let ((elisp-scope-block-alist (elisp-scope-local-new bare beg elisp-scope-block-alist))) + (elisp-scope-n body))) + (elisp-scope-n body))) + +(defun elisp-scope-return-from (name result) + (when-let* ((bare (and (symbol-with-pos-p name) (bare-symbol name))) + (pos (alist-get bare elisp-scope-block-alist))) + (elisp-scope-report 'block + (symbol-with-pos-pos name) (length (symbol-name bare)) pos)) + (elisp-scope-1 result)) + +(defvar elisp-scope-assume-func nil) + +(defun elisp-scope-sharpquote (arg) + (cond + ((or (symbol-with-pos-p arg) (symbolp arg)) + (let ((bare (bare-symbol arg))) + (cond + ((or (functionp bare) (memq bare elisp-scope-local-functions) (assq bare elisp-scope-flet-alist) elisp-scope-assume-func) + (elisp-scope-report-s arg 'function)) + (t (elisp-scope-report-s arg 'unknown))))) + ((consp arg) (elisp-scope-1 arg)))) + +(defun elisp-scope-loop-for-and (rest) + (if (eq (elisp-scope-sym-bare (car rest)) 'and) + (elisp-scope-loop-for elisp-scope--local (cadr rest) (cddr rest)) + (elisp-scope-loop rest))) + +(defun elisp-scope-loop-for-by (local expr rest) + (elisp-scope-1 expr) + (let ((elisp-scope--local local)) + (elisp-scope-loop-for-and rest))) + +(defun elisp-scope-loop-for-to (local expr rest) + (elisp-scope-1 expr) + (when-let* ((bare (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((eq bare 'by) + (elisp-scope-loop-for-by local (car more) (cdr more))) + (t (let ((elisp-scope--local local)) + (elisp-scope-loop-for-and rest)))))) + +(defun elisp-scope-loop-for-from (local expr rest) + (elisp-scope-1 expr) + (when-let* ((bare (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((memq bare '(to upto downto below above)) + (elisp-scope-loop-for-to local (car more) (cdr more))) + ((eq bare 'by) + (elisp-scope-loop-for-by local (car more) (cdr more))) + (t (let ((elisp-scope--local local)) + (elisp-scope-loop-for-and rest)))))) + +(defun elisp-scope-loop-for-= (local expr rest) + (elisp-scope-1 expr) + (when-let* ((bare (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((eq bare 'then) + (elisp-scope-loop-for-by local (car more) (cdr more))) + (t (let ((elisp-scope--local local)) + (elisp-scope-loop-for-and rest)))))) + +(defun elisp-scope-loop-for-being-the-hash-keys-of-using (form rest) + (let* ((var (cadr form)) + (bare (elisp-scope-sym-bare var)) + (beg (elisp-scope-sym-pos var))) + (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) + (let ((elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (elisp-scope-loop-for-and rest)))) + +(defun elisp-scope-loop-for-being-the-hash-keys-of (local expr rest) + (elisp-scope-1 expr) + (when-let* ((bare (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (let ((elisp-scope--local local)) + (cond + ((eq bare 'using) + (elisp-scope-loop-for-being-the-hash-keys-of-using (car more) (cdr more))) + (t (elisp-scope-loop-for-and rest)))))) + +(defun elisp-scope-loop-for-being-the-hash-keys (local word rest) + (when-let* ((bare (elisp-scope-sym-bare word))) + (cond + ((eq bare 'of) + (elisp-scope-loop-for-being-the-hash-keys-of local (car rest) (cdr rest)))))) + +(defun elisp-scope-loop-for-being-the (local word rest) + (when-let* ((bare (elisp-scope-sym-bare word))) + (cond + ((memq bare '(buffer buffers)) + (let ((elisp-scope--local local)) + (elisp-scope-loop-for-and rest))) + ((memq bare '( hash-key hash-keys + hash-value hash-values + key-code key-codes + key-binding key-bindings)) + (elisp-scope-loop-for-being-the-hash-keys local (car rest) (cdr rest)))))) + +(defun elisp-scope-loop-for-being (local next rest) + (elisp-scope-loop-for-being-the + local (car rest) + (if (memq (elisp-scope-sym-bare next) '(the each)) (cdr rest) rest))) + +(defun elisp-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 (elisp-scope-sym-pos var))) + (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) + (elisp-scope-loop-for (elisp-scope-local-new bare beg local) (cdr-safe vars) rest)) + (when-let* ((bare (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((memq bare '(from upfrom downfrom)) + (elisp-scope-loop-for-from local (car more) (cdr more))) + ((memq bare '( to upto downto below above + in on in-ref)) + (elisp-scope-loop-for-to local (car more) (cdr more))) + ((memq bare '(by + across across-ref)) + (elisp-scope-loop-for-by local (car more) (cdr more))) + ((eq bare '=) + (elisp-scope-loop-for-= local (car more) (cdr more))) + ((eq bare 'being) + (elisp-scope-loop-for-being local (car more) (cdr more))))))) + +(defun elisp-scope-loop-repeat (form rest) + (elisp-scope-1 form) + (elisp-scope-loop rest)) + +(defvar elisp-scope-loop-into-vars nil) + +(defun elisp-scope-loop-collect (expr rest) + (elisp-scope-1 expr) + (let ((bw (elisp-scope-sym-bare (car rest))) + (more (cdr rest))) + (if (eq bw 'into) + (let* ((var (car more)) + (bare (elisp-scope-sym-bare var)) + (beg (elisp-scope-sym-pos var))) + (if (memq bare elisp-scope-loop-into-vars) + (progn + (elisp-scope-s var) + (elisp-scope-loop (cdr more))) + (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) + (let ((elisp-scope-loop-into-vars (cons bare elisp-scope-loop-into-vars)) + (elisp-scope--local (elisp-scope-local-new bare beg elisp-scope--local))) + (elisp-scope-loop (cdr more))))) + (elisp-scope-loop rest)))) + +(defun elisp-scope-loop-with-and (rest) + (if (eq (elisp-scope-sym-bare (car rest)) 'and) + (elisp-scope-loop-with (cadr rest) (cddr rest)) + (elisp-scope-loop rest))) + +(defun elisp-scope-loop-with (var rest) + (let* ((bare (elisp-scope-sym-bare var)) + (beg (symbol-with-pos-pos var)) + (l (elisp-scope-local-new bare beg elisp-scope--local)) + (eql (car rest))) + (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) + (if (eq (elisp-scope-sym-bare eql) '=) + (let* ((val (cadr rest)) (more (cddr rest))) + (elisp-scope-1 val) + (let ((elisp-scope--local l)) + (elisp-scope-loop-with-and more))) + (let ((elisp-scope--local l)) + (elisp-scope-loop-with-and rest))))) + +(defun elisp-scope-loop-do (form rest) + (elisp-scope-1 form) + (if (consp (car rest)) + (elisp-scope-loop-do (car rest) (cdr rest)) + (elisp-scope-loop rest))) + +(defun elisp-scope-loop-named (name rest) + (let* ((beg (elisp-scope-sym-pos name)) + (bare (elisp-scope-sym-bare name))) + (when beg + (elisp-scope-report 'block beg (length (symbol-name bare)) beg)) + (let ((elisp-scope-block-alist (elisp-scope-local-new bare beg elisp-scope-block-alist))) + (elisp-scope-loop rest)))) + +(defun elisp-scope-loop-finally (next rest) + (if-let* ((bare (elisp-scope-sym-bare next))) + (cond + ((eq bare 'do) + (elisp-scope-loop-do (car rest) (cdr rest))) + ((eq bare 'return) + (elisp-scope-1 (car rest)) + (elisp-scope-loop (cdr rest)))) + (if (eq (elisp-scope-sym-bare (car-safe next)) 'return) + (progn + (elisp-scope-1 (cadr next)) + (elisp-scope-loop (cdr rest))) + (elisp-scope-loop-do next rest)))) + +(defun elisp-scope-loop-initially (next rest) + (if (eq (elisp-scope-sym-bare next) 'do) + (elisp-scope-loop-do (car rest) (cdr rest)) + (elisp-scope-loop-do next rest))) + +(defvar elisp-scope-loop-if-depth 0) + +(defun elisp-scope-loop-if (keyword condition rest) + (elisp-scope-1 condition) + (let ((elisp-scope-loop-if-depth (1+ elisp-scope-loop-if-depth)) + (elisp-scope--local + ;; `if' binds `it'. + (elisp-scope-local-new 'it (elisp-scope-sym-pos keyword) elisp-scope--local))) + (elisp-scope-loop rest))) + +(defun elisp-scope-loop-end (rest) + (let ((elisp-scope-loop-if-depth (1- elisp-scope-loop-if-depth))) + (unless (minusp elisp-scope-loop-if-depth) + (elisp-scope-loop rest)))) + +(defun elisp-scope-loop-and (rest) + (when (plusp elisp-scope-loop-if-depth) (elisp-scope-loop rest))) + +(defun elisp-scope-loop (forms) + (when forms + (let* ((kw (car forms)) + (bare (elisp-scope-sym-bare kw)) + (rest (cdr forms))) + (cond + ((memq bare '(for as)) + (elisp-scope-loop-for elisp-scope--local (car rest) (cdr rest))) + ((memq bare '( repeat while until always never thereis iter-by + return)) + (elisp-scope-loop-repeat (car rest) (cdr rest))) + ((memq bare '(collect append nconc concat vconcat count sum maximize minimize)) + (elisp-scope-loop-collect (car rest) (cdr rest))) + ((memq bare '(with)) + (elisp-scope-loop-with (car rest) (cdr rest))) + ((memq bare '(do)) (elisp-scope-loop-do (car rest) (cdr rest))) + ((memq bare '(named)) (elisp-scope-loop-named (car rest) (cdr rest))) + ((memq bare '(finally)) (elisp-scope-loop-finally (car rest) (cdr rest))) + ((memq bare '(initially)) (elisp-scope-loop-initially (car rest) (cdr rest))) + ((memq bare '(if when unless)) (elisp-scope-loop-if kw (car rest) (cdr rest))) + ((memq bare '(end)) (elisp-scope-loop-end rest)) + ((memq bare '(and else)) (elisp-scope-loop-and rest)))))) + +(defun elisp-scope-named-let (name bindings body &optional outtype) + (let ((bare (elisp-scope-sym-bare name)) + (beg (elisp-scope-sym-pos name))) + (when beg + (elisp-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 (elisp-scope-binding bare beg (length (symbol-name bare)))) + (elisp-scope-1 (cadr binding)))) + (let ((l elisp-scope--local)) + (dolist (binding bindings) + (when-let* ((sym (car (ensure-list binding))) + (bare (elisp-scope-sym-bare sym))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos sym) l)))) + (let ((elisp-scope-flet-alist (elisp-scope-local-new bare beg elisp-scope-flet-alist)) + (elisp-scope--local l)) + (elisp-scope-n body outtype))))) + +(defun elisp-scope-with-slots (spec-list object body) + (elisp-scope-1 object) + (elisp-scope-let spec-list body)) + +(defun elisp-scope-rx (regexps) + (dolist (regexp regexps) (elisp-scope-rx-1 regexp))) + +(defvar elisp-scope-rx-alist nil) + +(defun elisp-scope-rx-1 (regexp) + (if (consp regexp) + (let* ((head (car regexp)) + (bare (elisp-scope-sym-bare head))) + (when (and bare (symbol-with-pos-p head)) + (elisp-scope-report 'rx-construct + (symbol-with-pos-pos head) (length (symbol-name bare)) + (alist-get bare elisp-scope-rx-alist))) + (cond + ((memq bare '(literal regex regexp eval)) + (elisp-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)) + (elisp-scope-rx (cdr regexp))))) + (when-let* (((symbol-with-pos-p regexp)) + (bare (elisp-scope-sym-bare regexp))) + (elisp-scope-report 'rx-construct + (symbol-with-pos-pos regexp) (length (symbol-name bare)) + (alist-get bare elisp-scope-rx-alist))))) + +(defun elisp-scope-rx-define (name rest) + (when-let* ((bare (elisp-scope-sym-bare name))) + (elisp-scope-report 'rx-construct + (symbol-with-pos-pos name) (length (symbol-name bare)) nil)) + (if (not (cdr rest)) + (elisp-scope-rx-1 (car rest)) + (let ((l elisp-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 _)) + (elisp-scope-report 'ampersand beg len) + (elisp-scope-report 'rx-construct beg len beg)))))) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (elisp-scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (elisp-scope-local-new bare beg l))))) + (let ((elisp-scope-rx-alist l)) + (elisp-scope-rx-1 rx))))) + +(defun elisp-scope-rx-let (bindings body) + (if-let* ((binding (car bindings))) + (let ((name (car binding)) (rest (cdr binding))) + (when-let* ((bare (elisp-scope-sym-bare name)) + (beg (symbol-with-pos-pos name))) + (elisp-scope-report 'rx-construct + beg (length (symbol-name bare)) beg)) + (if (cdr rest) + (let ((l elisp-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 _)) + (elisp-scope-report 'ampersand beg len) + (elisp-scope-report 'rx-construct beg len beg)))))) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (elisp-scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (elisp-scope-local-new bare beg l))))) + (let ((elisp-scope-rx-alist l)) + (elisp-scope-rx-1 rx)) + (let ((elisp-scope-rx-alist (elisp-scope-local-new (elisp-scope-sym-bare name) + (elisp-scope-sym-pos name) + elisp-scope-rx-alist))) + (elisp-scope-rx-let (cdr bindings) body))) + (elisp-scope-rx-1 (car rest)) + (let ((elisp-scope-rx-alist (elisp-scope-local-new (elisp-scope-sym-bare name) + (elisp-scope-sym-pos name) + elisp-scope-rx-alist))) + (elisp-scope-rx-let (cdr bindings) body)))) + (elisp-scope-n body))) + +(defun elisp-scope-gv-define-expander (name handler) + (when-let* ((beg (elisp-scope-sym-pos name)) (bare (elisp-scope-sym-bare name))) + (elisp-scope-report 'defun beg (length (symbol-name bare)))) + (elisp-scope-1 handler)) + +(defun elisp-scope-gv-define-simple-setter (name setter rest) + (when-let* ((beg (elisp-scope-sym-pos name)) (bare (elisp-scope-sym-bare name))) + (elisp-scope-report 'defun beg (length (symbol-name bare)))) + (when-let* ((beg (elisp-scope-sym-pos setter)) (bare (elisp-scope-sym-bare setter))) + (elisp-scope-report 'function beg (length (symbol-name bare)))) + (elisp-scope-n rest)) + +(defun elisp-scope-face (face) + (if (or (elisp-scope-sym-bare face) + (keywordp (elisp-scope-sym-bare (car-safe face)))) + (elisp-scope-face-1 face) + (mapc #'elisp-scope-face-1 face))) + +(defun elisp-scope-face-1 (face) + (cond + ((symbol-with-pos-p face) + (when-let* ((beg (elisp-scope-sym-pos face)) (bare (elisp-scope-sym-bare face))) + (elisp-scope-report 'face beg (length (symbol-name bare))))) + ((keywordp (elisp-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 (elisp-scope-sym-bare kw)) + ((keywordp bare))) + (when-let* ((beg (elisp-scope-sym-pos kw)) + (len (length (symbol-name bare)))) + (elisp-scope-report 'constant beg len)) + (when (eq bare :inherit) + (when-let* ((beg (elisp-scope-sym-pos vl)) (fbare (elisp-scope-sym-bare vl))) + (elisp-scope-report 'face beg (length (symbol-name fbare)))))))))))) + +(defun elisp-scope-deftype (name args body) + (when-let* ((beg (elisp-scope-sym-pos name)) (bare (elisp-scope-sym-bare name))) + (elisp-scope-report 'deftype beg (length (symbol-name bare)))) + (elisp-scope-lambda args body)) + +(defun elisp-scope-widget-type (form) + (when-let* (((memq (elisp-scope-sym-bare (car-safe form)) '(quote \`))) + (type (cadr form))) + (elisp-scope-widget-type-1 type))) + +(defun elisp-scope-widget-type-1 (type) + (cond + ((symbol-with-pos-p type) + (when-let* ((beg (elisp-scope-sym-pos type)) (bare (elisp-scope-sym-bare type))) + (elisp-scope-report 'widget-type + (symbol-with-pos-pos type) + (length (symbol-name (bare-symbol type)))))) + ((consp type) + (let ((head (car type))) + (when-let* ((beg (elisp-scope-sym-pos head)) (bare (elisp-scope-sym-bare head))) + (elisp-scope-report 'widget-type beg (length (symbol-name bare)))) + (when-let* ((bare (elisp-scope-sym-bare head))) + (elisp-scope-widget-type-arguments bare (cdr type))))))) + +(defun elisp-scope-widget-type-keyword-arguments (head kw args) + (when-let* ((beg (elisp-scope-sym-pos kw)) + (len (length (symbol-name (bare-symbol kw))))) + (elisp-scope-report 'constant beg len)) + (cond + ((and (memq head '(plist alist)) + (memq kw '(:key-type :value-type))) + (elisp-scope-widget-type-1 (car args))) + ((memq kw '(:action :match :match-inline :validate)) + (when-let* ((fun (car args)) + (beg (elisp-scope-sym-pos fun)) + (bare (elisp-scope-sym-bare fun))) + (elisp-scope-report 'function beg (length (symbol-name bare))))) + ((memq kw '(:args)) + (mapc #'elisp-scope-widget-type-1 (car args)))) + ;; TODO: (restricted-sexp :match-alternatives CRITERIA) + (elisp-scope-widget-type-arguments head (cdr args))) + +(defun elisp-scope-widget-type-arguments (head args) + (let* ((arg (car args)) + (bare (elisp-scope-sym-bare arg))) + (if (keywordp bare) + (elisp-scope-widget-type-keyword-arguments head bare (cdr args)) + (elisp-scope-widget-type-arguments-1 head args)))) + +(defun elisp-scope-widget-type-arguments-1 (head args) + (cl-case head + ((list cons group vector choice radio set repeat checklist) + (mapc #'elisp-scope-widget-type-1 args)) + ((function-item) + (when-let* ((fun (car args)) + (beg (elisp-scope-sym-pos fun)) + (bare (elisp-scope-sym-bare fun))) + (elisp-scope-report 'function beg (length (symbol-name bare))))) + ((variable-item) + (when-let* ((var (car args)) + (beg (elisp-scope-sym-pos var)) + (bare (elisp-scope-sym-bare var))) + (elisp-scope-report 'variable beg (length (symbol-name bare))))))) + +(defun elisp-scope-quoted-group (sym-form) + (when-let* (((eq (elisp-scope-sym-bare (car-safe sym-form)) 'quote)) + (sym (cadr sym-form)) + (beg (elisp-scope-sym-pos sym)) + (bare (elisp-scope-sym-bare sym))) + (elisp-scope-report 'group beg (length (symbol-name bare))))) + +(defun elisp-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 (elisp-scope-sym-bare var)) + (when-let* ((beg (elisp-scope-sym-pos var)) + (len (length (symbol-name bare)))) + (elisp-scope-binding bare beg len)) + (cond + ((consp spec) + (let ((head (car spec)) (form (cadr spec))) + (and (eq 'eql (elisp-scope-sym-bare head)) + (not (or (symbolp form) (symbol-with-pos-p form))) + (elisp-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)))) + (elisp-scope-report 'type beg len)))) + (elisp-scope-defmethod-1 (elisp-scope-local-new bare (elisp-scope-sym-pos var) local) + (cdr args) body))))) + ((setq bare (elisp-scope-sym-bare arg)) + (cond + ((memq bare '(&optional &rest &body _)) + (when-let* ((beg (elisp-scope-sym-pos arg))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (elisp-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 (elisp-scope-sym-pos arg))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (elisp-scope-1 expr) + (cond + ((consp spec) + (let ((head (car spec)) (form (cadr spec))) + (and (eq 'eql (elisp-scope-sym-bare head)) + (not (or (symbolp form) (symbol-with-pos-p form))) + (elisp-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)))) + (elisp-scope-report 'type beg len beg)))) + (elisp-scope-defmethod-1 local more body))) + (t + (when-let* ((beg (elisp-scope-sym-pos arg)) + (len (length (symbol-name bare)))) + (elisp-scope-binding bare beg len)) + (elisp-scope-defmethod-1 (elisp-scope-local-new bare (elisp-scope-sym-pos arg) local) + (cdr args) body)))))) + (let ((elisp-scope--local local)) + (elisp-scope-n body)))) + +;; (defun elisp-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))) +;; (elisp-scope-defmethod-1 local local name (car rest) +;; (if (stringp (cadr rest)) (cddr rest) (cdr rest)))) + +(defun elisp-scope-defmethod (name rest) + (when-let* ((beg (elisp-scope-sym-pos name)) (bare (elisp-scope-sym-bare name))) + (elisp-scope-report 'defun beg (length (symbol-name bare)))) + ;; [EXTRA] + (when (eq (elisp-scope-sym-bare (car rest)) :extra) + (elisp-scope-s (car rest)) + (setq rest (cddr rest))) + ;; [QUALIFIER] + (when (keywordp (elisp-scope-sym-bare (car rest))) + (elisp-scope-s (car rest)) + (setq rest (cdr rest))) + ;; ARGUMENTS + (elisp-scope-defmethod-1 elisp-scope--local (car rest) (cdr rest))) + +(defun elisp-scope-cl-defun (name arglist body) + (let ((beg (elisp-scope-sym-pos name)) + (bare (elisp-scope-sym-bare name))) + (when beg (elisp-scope-report 'defun beg (length (symbol-name bare)))) + (let ((elisp-scope-block-alist (elisp-scope-local-new bare beg elisp-scope-block-alist))) + (elisp-scope-cl-lambda arglist body)))) + +(defun elisp-scope-cl-lambda (arglist body) + (elisp-scope-cl-lambda-1 arglist nil body)) + +(defun elisp-scope-cl-lambda-1 (arglist more body) + (cond + (arglist + (if (consp arglist) + (let ((head (car arglist))) + (if (consp head) + (elisp-scope-cl-lambda-1 head (cons (cdr arglist) more) body) + (let ((bare (elisp-scope-sym-bare head))) + (if (memq bare '(&optional &rest &body &key &aux &whole &cl-defs &cl-quote)) + (progn + (when-let* ((beg (elisp-scope-sym-pos head))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&optional (elisp-scope-cl-lambda-optional (cadr arglist) (cddr arglist) more body)) + (&cl-defs (elisp-scope-cl-lambda-defs (cadr arglist) (cddr arglist) more body)) + ((&rest &body) (elisp-scope-cl-lambda-rest (cadr arglist) (cddr arglist) more body)) + (&key (elisp-scope-cl-lambda-key (cadr arglist) (cddr arglist) more body)) + (&aux (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body)) + (&whole (elisp-scope-cl-lambda-1 (cdr arglist) more body)))) + (when-let* ((beg (elisp-scope-sym-pos head))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (let ((elisp-scope--local (elisp-scope-local-new bare (elisp-scope-sym-pos head) elisp-scope--local))) + (elisp-scope-cl-lambda-1 (cdr arglist) more body)))))) + (elisp-scope-cl-lambda-1 (list '&rest arglist) more body))) + (more (elisp-scope-cl-lambda-1 (car more) (cdr more) body)) + (t (elisp-scope-lambda nil body)))) + +(defun elisp-scope-cl-lambda-defs (arg arglist more body) + (when (consp arg) + (let ((def (car arg)) + (defs (cdr arg))) + (elisp-scope-1 def) + (dolist (d defs) (elisp-scope-n (cdr-safe d))))) + (elisp-scope-cl-lambda-1 arglist more body)) + +(defun elisp-scope-cl-lambda-optional (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l elisp-scope--local) + (init (cadr a)) + (svar (caddr a))) + (elisp-scope-1 init) + (if (consp var) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 var (cons (append (when svar (list svar)) + (cons '&optional arglist)) + more) + body)) + (when-let* ((bare (elisp-scope-sym-bare svar))) + (when-let* ((beg (elisp-scope-sym-pos svar))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos svar) l))) + (when-let* ((bare (elisp-scope-sym-bare var))) + (when-let* ((beg (elisp-scope-sym-pos var))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let* ((bare (elisp-scope-sym-bare head)) + ((memq bare '(&rest &body &key &aux)))) + (progn + (when-let* ((beg (elisp-scope-sym-pos head))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + ((&rest &body) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-rest (cadr arglist) (cddr arglist) more body))) + (&key (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) + (&aux (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-optional head (cdr arglist) more body))))) + (more + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((elisp-scope--local l)) (elisp-scope-lambda nil body))))))) + +(defun elisp-scope-cl-lambda-rest (var arglist more body) + (let* ((l elisp-scope--local)) + (if (consp var) + (elisp-scope-cl-lambda-1 var (cons arglist more) body) + (when-let* ((bare (elisp-scope-sym-bare var))) + (when-let* ((beg (elisp-scope-sym-pos var))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let* ((bare (elisp-scope-sym-bare head)) + ((memq bare '(&key &aux)))) + (progn + (when-let* ((beg (elisp-scope-sym-pos head))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&key + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) + (&aux + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 (car more) (cdr more) body))))) + (more (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((elisp-scope--local l)) + (elisp-scope-lambda nil body))))))) + +(defun elisp-scope-cl-lambda-key (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l elisp-scope--local) + (init (cadr a)) + (svar (caddr a)) + (kw (car-safe var))) + (elisp-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 (elisp-scope-sym-bare kw)) + ((keywordp bare))) + (when-let* ((beg (elisp-scope-sym-pos kw))) + (elisp-scope-report 'constant beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos svar) l))) + (if (consp var) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 var (cons (append (when svar (list svar)) + (cons '&key arglist)) + more) + body)) + (when-let* ((bare (elisp-scope-sym-bare svar))) + (when-let* ((beg (elisp-scope-sym-pos svar))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos svar) l))) + (when-let* ((bare (elisp-scope-sym-bare var))) + (when-let* ((beg (elisp-scope-sym-pos var))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let* ((bare (elisp-scope-sym-bare head)) + ((memq bare '(&aux &allow-other-keys)))) + (progn + (when-let* ((beg (elisp-scope-sym-pos head))) + (elisp-scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&aux + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))) + (&allow-other-keys + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 (car more) (cdr more) body))))) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-key head (cdr arglist) more body))))) + (more (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((elisp-scope--local l)) + (elisp-scope-lambda nil body))))))) + +(defun elisp-scope-cl-lambda-aux (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l elisp-scope--local) + (init (cadr a))) + (elisp-scope-1 init) + (if (consp var) + (let ((elisp-scope--local l)) + (elisp-scope-cl-lambda-1 var (cons arglist more) body)) + (when-let* ((bare (elisp-scope-sym-bare var))) + (when-let* ((beg (elisp-scope-sym-pos var))) + (elisp-scope-binding bare beg (length (symbol-name bare)))) + (setq l (elisp-scope-local-new bare (elisp-scope-sym-pos var) l))) + (let ((elisp-scope--local l)) + (cond + (arglist (elisp-scope-cl-lambda-aux (car arglist) (cdr arglist) more body)) + (more (elisp-scope-cl-lambda-1 (car more) (cdr more) body)) + (t (elisp-scope-lambda nil body))))))) + +(defvar elisp-scope-macrolet-alist nil) + +(defun elisp-scope-cl-macrolet (bindings body) + (if-let* ((b (car bindings))) + (let ((name (car b)) + (arglist (cadr b)) + (mbody (cddr b))) + (elisp-scope-cl-lambda arglist mbody) + (when-let* ((bare (elisp-scope-sym-bare name))) + (when-let* ((beg (elisp-scope-sym-pos name))) + (elisp-scope-report 'macro beg (length (symbol-name bare)) beg)) + (let ((elisp-scope-macrolet-alist (elisp-scope-local-new bare (elisp-scope-sym-pos name) elisp-scope-macrolet-alist))) + (elisp-scope-cl-macrolet (cdr bindings) body)))) + (elisp-scope-n body))) + +(defun elisp-scope-define-minor-mode (mode _doc body) + (let ((explicit-var nil) (command t)) + (while-let ((kw (car-safe body)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (when-let* ((beg (elisp-scope-sym-pos kw))) + (elisp-scope-report 'constant beg (length (symbol-name bkw)))) + (cl-case bkw + ((:init-value :keymap :after-hook :initialize) + (elisp-scope-1 (cadr body))) + (:lighter (elisp-scope-mode-line-construct (cadr body))) + ((:interactive) + (let ((val (cadr body))) + (when (consp val) (mapc #'elisp-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 + (elisp-scope-1 (car place)) + (elisp-scope-sharpquote tail)) + (elisp-scope-1 place))) + (setq explicit-var t)) + ((:group) + (elisp-scope-quoted-group (cadr body))) + ((:predicate) ;For globalized minor modes. + (elisp-scope-global-minor-mode-predicate (cadr body))) + ((:on :off) + (let ((obod (cdr body))) + (while (and obod (not (keywordp (elisp-scope-sym-bare (car obod))))) + (elisp-scope-1 (pop obod))) + (setq body (cons bkw (cons nil obod)))))) + (setq body (cddr body))) + (when-let* ((bare (elisp-scope-sym-bare mode)) (beg (elisp-scope-sym-pos mode)) + (typ (if command 'defcmd 'defun))) + (elisp-scope-report typ beg (length (symbol-name bare))) + (unless explicit-var + (elisp-scope-report 'defvar beg (length (symbol-name bare))))) + (elisp-scope-n body))) + +(defun elisp-scope-global-minor-mode-predicate (pred) + (if (consp pred) + (if (eq 'not (elisp-scope-sym-bare (car pred))) + (mapc #'elisp-scope-global-minor-mode-predicate (cdr pred)) + (mapc #'elisp-scope-global-minor-mode-predicate pred)) + (elisp-scope-major-mode-name pred))) + +(defun elisp-scope-major-mode-name (mode) + (when-let* ((beg (elisp-scope-sym-pos mode)) + (bare (bare-symbol mode)) + ((not (booleanp bare))) + (len (length (symbol-name bare)))) + (elisp-scope-report 'major-mode beg len))) + +(defun elisp-scope-mode-line-construct (format) + (elisp-scope-mode-line-construct-1 format)) + +(defun elisp-scope-mode-line-construct-1 (format) + (cond + ((symbol-with-pos-p format) + (elisp-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 #'elisp-scope-mode-line-construct-1 format)) + ((or (symbolp head) (symbol-with-pos-p head)) + (elisp-scope-s head) + (cl-case (bare-symbol head) + (:eval + (elisp-scope-1 (cadr format))) + (:propertize + (elisp-scope-mode-line-construct-1 (cadr format)) + (when-let* ((props (cdr format)) + (symbols-with-pos-enabled t) + (val-form (plist-get props 'face))) + (elisp-scope-face-1 val-form))) + (otherwise + (elisp-scope-mode-line-construct-1 (cadr format)) + (elisp-scope-mode-line-construct-1 (caddr format)))))))))) + +(defcustom elisp-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 elisp-scope-unsafe-macros + '( static-if static-when static-unless + cl-eval-when eval-when-compile eval-and-compile let-when-compile + rx cl-macrolet nnoo-define-basics)) + +(defun elisp-scope-safe-macro-p (macro) + (and (not (memq macro elisp-scope-unsafe-macros)) + (or (eq elisp-scope-safe-macros t) + (memq macro elisp-scope-safe-macros) + (get macro 'safe-macro) + (trusted-content-p)))) + +(defvar warning-minimum-log-level) + +(defmacro elisp-scope-define-analyzer (fsym args &rest body) + (declare (indent defun)) + (let ((analyzer (intern (concat "elisp-scope--analyze-" (symbol-name fsym))))) + `(progn + (defun ,analyzer ,args ,@body) + (put ',fsym 'elisp-scope-analyzer #',analyzer)))) + +(defmacro elisp-scope--define-function-analyzer (fsym args type &rest body) + (declare (indent defun)) + (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + `(progn + (defun ,helper ,args ,@body) + (elisp-scope-define-analyzer ,fsym (f &rest args) + (elisp-scope-report-s f ',type) + (apply #',helper args) + (elisp-scope-n args))))) + +(defmacro elisp-scope-define-function-analyzer (fsym args &rest body) + (declare (indent defun)) + `(elisp-scope--define-function-analyzer ,fsym ,args function ,@body) + ;; (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + ;; `(progn + ;; (defun ,helper ,args ,@body) + ;; (elisp-scope-define-analyzer ,fsym (l f &rest args) + ;; (elisp-scope-report-s f 'function) + ;; (apply #',helper args) + ;; (elisp-scope-n l args)))) + ) + +(defmacro elisp-scope-define-func-analyzer (fsym args &rest body) + (declare (indent defun)) + (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + `(progn + (defun ,helper ,args ,@body) + (elisp-scope-define-analyzer ,fsym (f &rest args) + (elisp-scope-report-s f 'function) + (apply #',helper args))))) + +(defmacro elisp-scope-define-macro-analyzer (fsym args &rest body) + (declare (indent defun)) + (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + `(progn + (defun ,helper ,args ,@body) + (elisp-scope-define-analyzer ,fsym (f &rest args) + (elisp-scope-report-s f 'macro) + (apply #',helper args))))) + +(defmacro elisp-scope-define-special-form-analyzer (fsym args &rest body) + (declare (indent defun)) + (let* ((helper (intern (concat "elisp-scope--analyze-" (symbol-name fsym) "-1")))) + `(progn + (defun ,helper ,args ,@body) + (elisp-scope-define-analyzer ,fsym (f &rest args) + (elisp-scope-report-s f 'macro) + (apply #',helper args))))) + +(defun elisp-scope--unquote (form) + (when (memq (elisp-scope-sym-bare (car-safe form)) '(quote function \`)) + (cadr form))) + +(elisp-scope-define-analyzer with-suppressed-warnings (f warnings &rest body) + (elisp-scope-report-s f 'macro) + (dolist (warning warnings) + (when-let* ((wsym (car-safe warning))) + (elisp-scope-report-s wsym 'warning-type))) + (elisp-scope-n body)) + +(elisp-scope-define-analyzer eval (f form &optional lexical) + (elisp-scope-report-s f 'function) + (if-let* ((quoted (elisp-scope--unquote form))) + (elisp-scope-1 quoted) + (elisp-scope-1 form)) + (elisp-scope-1 lexical)) + +(elisp-scope-define-func-analyzer funcall (&optional f &rest args) + (elisp-scope-1 f '(symbol . function)) + (dolist (arg args) (elisp-scope-1 arg))) + +(put 'apply 'elisp-scope-analyzer #'elisp-scope--analyze-funcall) + +(elisp-scope-define-func-analyzer defalias (&optional sym def docstring) + (elisp-scope-1 sym '(symbol . defun)) + (elisp-scope-1 def '(symbol . defun)) + (elisp-scope-1 docstring)) + +(elisp-scope-define-function-analyzer oclosure--define + (&optional name _docstring parent-names _slots &rest props) + (when-let* ((quoted (elisp-scope--unquote name))) (elisp-scope-report-s quoted 'defoclosure)) + (when-let* ((qs (elisp-scope--unquote parent-names))) + (dolist (q qs) + (elisp-scope-report-s q 'oclosure))) + (while-let ((kw (car-safe props)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + (:predicate + (when-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-report-s q 'defun)))) + (setq props (cddr props)))) + +(elisp-scope-define-function-analyzer define-charset + (&optional name _docstring &rest _props) + (when-let* ((quoted (elisp-scope--unquote name))) (elisp-scope-report-s quoted 'defcharset))) + +(elisp-scope-define-function-analyzer define-charset-alias + (&optional alias charset) + (when-let* ((quoted (elisp-scope--unquote alias))) (elisp-scope-report-s quoted 'defcharset)) + (when-let* ((quoted (elisp-scope--unquote charset))) (elisp-scope-report-s quoted 'charset))) + +(elisp-scope-define-func-analyzer charset-chars + (&optional charset &rest rest) + (elisp-scope-1 charset '(symbol . charset)) + (mapc #'elisp-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 'elisp-scope-analyzer #'elisp-scope--analyze-charset-chars)) + +(elisp-scope-define-func-analyzer define-coding-system + (&optional name &rest rest) + (elisp-scope-1 name '(symbol . defcoding)) + (mapc #'elisp-scope-1 rest)) + +(elisp-scope-define-func-analyzer define-coding-system-alias + (&optional alias coding-system) + (elisp-scope-1 alias '(symbol . defcoding)) + (elisp-scope-1 coding-system '(symbol . coding))) + +(elisp-scope-define-function-analyzer decode-coding-region + (&optional _start _end coding-system &rest _) + (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-scope-report-s quoted 'coding))) + +(put 'encode-coding-region 'elisp-scope-analyzer #'elisp-scope--analyze-decode-coding-region) + +(elisp-scope-define-function-analyzer decode-coding-string + (&optional _string coding-system &rest _) + (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-scope-report-s quoted 'coding))) + +(dolist (sym '(encode-coding-char encode-coding-string)) + (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-decode-coding-string)) + +(elisp-scope-define-function-analyzer coding-system-mnemonic + (&optional coding-system &rest _) + (when-let* ((quoted (elisp-scope--unquote coding-system))) (elisp-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 'elisp-scope-analyzer #'elisp-scope--analyze-coding-system-mnemonic)) + +(elisp-scope-define-func-analyzer thing-at-point (&optional thing no-props) + (elisp-scope-1 thing '(symbol . thing)) + (elisp-scope-1 no-props)) + +(dolist (sym '( forward-thing + beginning-of-thing + end-of-thing + bounds-of-thing-at-point)) + (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-thing-at-point)) + +(elisp-scope-define-func-analyzer bounds-of-thing-at-mouse (&optional event thing) + (elisp-scope-1 event) + (elisp-scope-1 thing '(symbol . thing))) + +(elisp-scope-define-func-analyzer thing-at-mouse (&optional event thing no-props) + (elisp-scope-1 event) + (elisp-scope-1 thing '(symbol . thing)) + (elisp-scope-1 no-props)) + +(elisp-scope-define-function-analyzer custom-declare-variable (sym _default _doc &rest args) + (when-let* ((quoted (elisp-scope--unquote sym))) (elisp-scope-report-s quoted 'defvar)) + (while-let ((kw (car-safe args)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:type + (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-widget-type-1 quoted))) + (:group + (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s quoted 'group)))) + (setq args (cddr args)))) + +(elisp-scope-define-function-analyzer custom-declare-group (sym _members _doc &rest args) + (when-let* ((quoted (elisp-scope--unquote sym))) (elisp-scope-report-s quoted 'defgroup)) + (while-let ((kw (car-safe args)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:group + (when-let* ((quoted (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s quoted 'group)))) + (setq args (cddr args)))) + +(elisp-scope-define-function-analyzer custom-declare-face (face spec _doc &rest args) + (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-report-s q 'defface)) + (when-let* ((q (elisp-scope--unquote spec))) + (when (consp q) (dolist (s q) (elisp-scope-face (cdr s))))) + (while-let ((kw (car-safe args)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:group + (when-let* ((q (elisp-scope--unquote (cadr args)))) (elisp-scope-report-s q 'group)))) + (setq args (cddr args)))) + +(defun elisp-scope-typep (type) + (cond + ((or (symbolp type) (symbol-with-pos-p type)) + (unless (booleanp (elisp-scope-sym-bare type)) + (elisp-scope-report-s type 'type))) + ((consp type) + (cond + ((memq (elisp-scope-sym-bare (car type)) '(and or not)) + (mapc #'elisp-scope-typep (cdr type))) + ((eq (elisp-scope-sym-bare (car type)) 'satisfies) + (elisp-scope-report-s (cadr type) 'function)))))) + +(elisp-scope-define-function-analyzer cl-typep (_val type) + (when-let* ((q (elisp-scope--unquote type))) + (elisp-scope-typep q))) + +(elisp-scope-define-function-analyzer pulse-momentary-highlight-region (_start _end &optional face) + (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-face q))) + +(elisp-scope--define-function-analyzer throw (tag _value) non-local-exit + (when-let* ((q (elisp-scope--unquote tag))) (elisp-scope-report-s q 'throw-tag))) + +(elisp-scope--define-function-analyzer signal (error-symbol &optional _data) non-local-exit + (when-let* ((q (elisp-scope--unquote error-symbol))) (elisp-scope-report-s q 'condition))) + +(elisp-scope--define-function-analyzer kill-emacs (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer abort-recursive-edit (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer top-level (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer exit-recursive-edit (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer tty-frame-restack (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer error (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer user-error (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer minibuffer-quit-recursive-edit (&rest _) non-local-exit) +(elisp-scope--define-function-analyzer exit-minibuffer (&rest _) non-local-exit) + +(elisp-scope-define-func-analyzer run-hooks (&rest hooks) + (dolist (hook hooks) (elisp-scope-1 hook '(symbol . variable)))) + +(elisp-scope-define-func-analyzer fboundp (&optional symbol) + (elisp-scope-1 symbol '(symbol . function))) + +(elisp-scope-define-function-analyzer overlay-put (&optional _ov prop val) + (when-let* ((q (elisp-scope--unquote prop)) + ((eq (elisp-scope-sym-bare q) 'face)) + (face (elisp-scope--unquote val))) + (elisp-scope-face face))) + +(elisp-scope-define-function-analyzer add-face-text-property (&optional _start _end face &rest _) + (when-let* ((q (elisp-scope--unquote face))) (elisp-scope-face q))) + +(elisp-scope-define-function-analyzer facep (&optional face &rest _) + (when-let* ((q (elisp-scope--unquote face))) (elisp-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 'elisp-scope-analyzer #'elisp-scope--analyze-facep)) + +(elisp-scope-define-func-analyzer boundp (&optional var &rest rest) + (elisp-scope-1 var '(symbol . variable)) + (mapc #'elisp-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 'elisp-scope-analyzer #'elisp-scope--analyze-boundp)) + +(elisp-scope-define-function-analyzer defvaralias (new base &optional _docstring) + (when-let* ((q (elisp-scope--unquote new))) (elisp-scope-report-s q 'defvar)) + (when-let* ((q (elisp-scope--unquote base))) (elisp-scope-report-s q 'variable))) + +(elisp-scope-define-func-analyzer define-error (&optional name message parent) + (elisp-scope-1 name '(symbol . defcondition)) + (elisp-scope-1 message) + (elisp-scope-1 parent '(or (symbol . condition) + (repeat . (symbol . condition))))) + +(elisp-scope-define-function-analyzer featurep (feature &rest _) + (when-let* ((q (elisp-scope--unquote feature))) (elisp-scope-report-s q 'feature))) + +(put 'require 'elisp-scope-analyzer #'elisp-scope--analyze-featurep) + +(elisp-scope-define-function-analyzer provide (feature &rest _) + (when-let* ((q (elisp-scope--unquote feature))) (elisp-scope-report-s q 'deffeature))) + +(elisp-scope-define-function-analyzer put-text-property (&optional _ _ prop val _) + (when (memq (elisp-scope-sym-bare (elisp-scope--unquote prop)) '(mouse-face face)) + (when-let* ((q (elisp-scope--unquote val))) (elisp-scope-face q)))) + +(put 'remove-overlays 'elisp-scope-analyzer #'elisp-scope--analyze-put-text-property) + +(elisp-scope-define-function-analyzer propertize (_string &rest props) + (while props + (cl-case (elisp-scope-sym-bare (elisp-scope--unquote (car props))) + ((face mouse-face) + (when-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-face q)))) + (setq props (cddr props)))) + +(elisp-scope-define-function-analyzer eieio-defclass-internal (name superclasses _ _) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftype)) + (when-let* ((q (elisp-scope--unquote superclasses))) + (dolist (sup q) (elisp-scope-report-s sup 'type)))) + +(elisp-scope-define-function-analyzer cl-struct-define + (name _doc parent _type _named _slots _children _tab _print) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftype)) + (when-let* ((q (elisp-scope--unquote parent))) (elisp-scope-report-s q 'type))) + +(elisp-scope-define-function-analyzer define-widget (name class _doc &rest args) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'widget-type)) + (when-let* ((q (elisp-scope--unquote class))) (elisp-scope-report-s q 'widget-type)) + (while-let ((kw (car-safe args)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:type + (when-let* ((q (elisp-scope--unquote (cadr args)))) (elisp-scope-widget-type-1 q))) + (:args + (when-let* ((q (elisp-scope--unquote (cadr args)))) (mapc #'elisp-scope-widget-type-1 q)))) + (setq args (cddr args)))) + +(elisp-scope-define-function-analyzer provide-theme (name &rest _) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'theme))) + +(dolist (sym '(enable-theme disable-theme load-theme custom-theme-p)) + (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-provide-theme)) + +(elisp-scope-define-function-analyzer custom-theme-set-variables (theme &rest args) + (when-let* ((q (elisp-scope--unquote theme))) (elisp-scope-report-s q 'theme)) + (dolist (arg args) + (when-let* ((q (elisp-scope--unquote arg))) + (when (consp q) + (elisp-scope-report-s (pop q) 'variable) + (when (consp q) + (elisp-scope-1 (pop q)) + (dolist (request (car (cdr-safe q))) + (elisp-scope-report-s request 'feature))))))) + +(elisp-scope-define-function-analyzer custom-declare-theme (name &rest _) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deftheme))) + +(elisp-scope-define-function-analyzer eieio-oref (_obj slot) + (when-let* ((q (elisp-scope--unquote slot))) (elisp-scope-report-s q 'slot))) + +(dolist (fun '(slot-boundp slot-makeunbound slot-exists-p eieio-oref-default)) + (put fun 'elisp-scope-analyzer #'elisp-scope--analyze-eieio-oref)) + +(elisp-scope-define-function-analyzer eieio-oset (_obj slot _value) + (when-let* ((q (elisp-scope--unquote slot))) (elisp-scope-report-s q 'slot))) + +(put 'eieio-oset-default 'elisp-scope-analyzer #'elisp-scope--analyze-eieio-oset) + +(elisp-scope-define-function-analyzer derived-mode-p (modes &rest _obsolete) + (when-let* ((q (elisp-scope--unquote modes))) (elisp-scope-report-s q 'major-mode))) + +(elisp-scope-define-func-analyzer derived-mode-set-parent (&optional mode parent) + (elisp-scope-1 mode '(symbol . major-mode)) + (elisp-scope-1 parent '(symbol . major-mode))) + +(elisp-scope-define-func-analyzer elisp-scope-report (type &rest args) + (elisp-scope-1 type '(symbol . symbol-type)) + (mapc #'elisp-scope-1 args)) + +(elisp-scope-define-func-analyzer elisp-scope-report-s (&optional sym type) + (elisp-scope-1 sym) + (elisp-scope-1 type '(symbol . symbol-type))) + +(elisp-scope-define-func-analyzer elisp-scope-1 (&optional form outtype) + (elisp-scope-1 form) + (elisp-scope-1 outtype 'type)) + +(elisp-scope-define-function-analyzer icons--register (&optional name parent _spec _doc kws) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'deficon)) + (when-let* ((q (elisp-scope--unquote parent))) (elisp-scope-report-s q 'icon)) + (when-let* ((q (elisp-scope--unquote kws))) + (while-let ((kw (car-safe q)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + (:group (elisp-scope-report-s (cadr q) 'group))) + (setq q (cddr q))))) + +(elisp-scope-define-function-analyzer setopt--set (&optional var _val) + (when-let* ((q (elisp-scope--unquote var))) (elisp-scope-report-s q 'variable))) + +(elisp-scope-define-function-analyzer autoload (&optional func _file _doc int &rest _) + (when-let* ((q (elisp-scope--unquote func))) (elisp-scope-report-s q 'function)) + (when-let* ((q (elisp-scope--unquote int)) ((listp q))) + (dolist (mode q) (elisp-scope-report-s mode 'major-mode)))) + +(elisp-scope-define-function-analyzer minibuffer--define-completion-category (&optional name parents &rest _) + (when-let* ((q (elisp-scope--unquote name))) (elisp-scope-report-s q 'completion-category-definition)) + (when-let* ((q (elisp-scope--unquote parents))) + (dolist (p (ensure-list q)) (elisp-scope-report-s p 'completion-category)))) + +;; (elisp-scope-define-macro-analyzer define-completion-category (l &optional name parent &rest rest) +;; (elisp-scope-report-s name 'completion-category-definition) +;; (elisp-scope-report-s parent 'completion-category) +;; (elisp-scope-n l rest)) + +(elisp-scope-define-func-analyzer completion-table-with-category (&optional category table) + (elisp-scope-1 category '(symbol . completion-category)) + (elisp-scope-1 table)) + +(defun elisp-scope--easy-menu-do-define-menu (menu) + (let ((items (cdr menu))) + (while-let ((kw (car-safe items)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + ((:active :label :visible) (elisp-scope-1 (cadr items))) + ((:filter) (elisp-scope-sharpquote (cadr items)))) + (setq items (cddr items))) + (dolist (item items) + (cond + ((vectorp item) + (when (length> item 2) + (elisp-scope-sharpquote (aref item 1)) + (let ((it (cddr (append item nil)))) + (elisp-scope-1 (car it)) + (while-let ((kw (car-safe it)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + ((:active :enable :label :visible :suffix :selected) (elisp-scope-1 (cadr it)))) + (setq it (cddr it)))))) + ((consp item) (elisp-scope--easy-menu-do-define-menu item)))))) + +(elisp-scope-define-function-analyzer easy-menu-do-define (&optional _symbol _maps _doc menu) + (when-let* ((q (elisp-scope--unquote menu))) + (elisp-scope--easy-menu-do-define-menu q))) + +(elisp-scope-define-function-analyzer define-key (&optional _keymaps _key def _remove) + (when-let* ((q (elisp-scope--unquote def))) + (cond + ((eq (elisp-scope-sym-bare (car-safe q)) 'menu-item) + (let ((fn (caddr q)) (it (cdddr q))) + (elisp-scope-sharpquote fn) + (while-let ((kw (car-safe it)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + ((:active :enable :label :visible :suffix :selected) (elisp-scope-1 (cadr it))) + ((:filter) (elisp-scope-sharpquote (cadr it)))) + (setq it (cddr it))))) + ((or (symbolp q) (symbol-with-pos-p q)) + (elisp-scope-report-s q 'function))))) + +(elisp-scope-define-function-analyzer eval-after-load (&optional file form) + (when-let* ((q (elisp-scope--unquote file))) (elisp-scope-report-s q 'feature)) + (when-let* ((q (elisp-scope--unquote form))) (elisp-scope-1 q))) + +(elisp-scope-define-macro-analyzer define-globalized-minor-mode (global mode turn-on &rest body) + (elisp-scope-report-s mode 'function) + (elisp-scope-report-s turn-on 'function) + (elisp-scope-define-minor-mode global nil body)) + +(elisp-scope-define-macro-analyzer define-derived-mode (&optional child parent name &rest body) + (elisp-scope-report-s child 'major-mode-definition) + (elisp-scope-report-s parent 'major-mode) + (elisp-scope-mode-line-construct name) + (when (stringp (car body)) (pop body)) + (while-let ((kw (car-safe body)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + (:group (elisp-scope-quoted-group (cadr body))) + ((:syntax-table :abbrev-table :after-hook) (elisp-scope-1 (cadr body)))) + (setq body (cddr body))) + (elisp-scope-n body)) + +(elisp-scope-define-macro-analyzer lambda (args &rest body) + (elisp-scope-lambda args body)) + +(defun elisp-scope-oclosure-lambda-1 (local bindings args body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (elisp-scope-sym-bare sym)) + (len (length (symbol-name bare))) + (beg (elisp-scope-sym-pos sym))) + (when beg (elisp-scope-binding bare beg len)) + (elisp-scope-1 (cadr binding)) + (elisp-scope-oclosure-lambda-1 + (if bare (elisp-scope-local-new bare beg local) local) + (cdr bindings) args body)) + (let ((elisp-scope--local local)) + (elisp-scope-lambda args body)))) + +(defun elisp-scope-oclosure-lambda (spec args body) + (let ((type (car-safe spec))) + (elisp-scope-report-s type 'oclosure)) + (elisp-scope-oclosure-lambda-1 elisp-scope--local (cdr-safe spec) args body)) + +(elisp-scope-define-macro-analyzer oclosure-lambda (&optional spec args &rest body) + (elisp-scope-oclosure-lambda spec args body)) + +(elisp-scope-define-macro-analyzer cl-loop (&rest clauses) + (elisp-scope-loop clauses)) + +(elisp-scope-define-macro-analyzer named-let (name bindings &rest body) + (elisp-scope-named-let name bindings body elisp-scope--output-type)) + +(elisp-scope-define-macro-analyzer cl-flet (bindings &rest body) + (elisp-scope-flet bindings body)) + +(elisp-scope-define-macro-analyzer cl-labels (bindings &rest body) + (elisp-scope-labels bindings body)) + +(elisp-scope-define-macro-analyzer with-slots (spec-list object &rest body) + (elisp-scope-with-slots spec-list object body)) + +(elisp-scope-define-macro-analyzer cl-defmethod (name &rest rest) + (elisp-scope-defmethod name rest)) + +(elisp-scope-define-macro-analyzer cl-destructuring-bind (args expr &rest body) + (elisp-scope-1 expr) + (elisp-scope-cl-lambda args body)) + +(elisp-scope-define-macro-analyzer declare-function (&optional fn _file arglist _fileonly) + (elisp-scope-report-s fn 'function) + (elisp-scope-lambda (and (listp arglist) arglist) nil)) + +(elisp-scope-define-macro-analyzer cl-block (name &rest body) + (elisp-scope-block name body)) + +(elisp-scope-define-macro-analyzer cl-return-from (name &optional result) + (elisp-scope-return-from name result)) + +(elisp-scope-define-macro-analyzer rx (&rest regexps) + ;; Unsafe macro! + (elisp-scope-rx regexps)) + +(elisp-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)))) + (elisp-scope-cl-tagbody (nreverse labels) (nreverse statements)))) + +(defvar elisp-scope-label-alist nil) + +(defun elisp-scope-cl-tagbody (labels statements) + (if labels + (let* ((label (car labels)) + (bare (elisp-scope-sym-bare label))) + (when-let* ((beg (elisp-scope-sym-pos label))) + (elisp-scope-report 'label beg (length (symbol-name bare)) beg)) + (let ((elisp-scope-label-alist + (if bare + (elisp-scope-local-new bare (elisp-scope-sym-pos label) elisp-scope-label-alist) + elisp-scope-label-alist))) + (elisp-scope-cl-tagbody (cdr labels) statements))) + (elisp-scope-n statements))) + +(elisp-scope-define-macro-analyzer go (label) + ;; TODO: Change to a local macro defintion induced by `cl-tagbody'. + (when-let* ((bare (elisp-scope-sym-bare label)) + (pos (alist-get bare elisp-scope-label-alist)) + (beg (elisp-scope-sym-pos label))) + (elisp-scope-report 'label beg (length (symbol-name bare)) pos))) + +(elisp-scope-define-macro-analyzer rx-define (name &rest rest) + (elisp-scope-rx-define name rest)) + +(elisp-scope-define-macro-analyzer rx-let (bindings &rest body) + (elisp-scope-rx-let bindings body)) + +(elisp-scope-define-macro-analyzer let-when-compile (bindings &rest body) + ;; Unsafe macro! + (elisp-scope-let* bindings body)) + +(elisp-scope-define-macro-analyzer cl-eval-when (_when &rest body) + ;; Unsafe macro! + (elisp-scope-n body)) + +(elisp-scope-define-macro-analyzer cl-macrolet (bindings &rest body) + ;; Unsafe macro! + (elisp-scope-cl-macrolet bindings body)) + +(elisp-scope-define-macro-analyzer cl-symbol-macrolet (bindings &rest body) + ;; Unsafe macro! + (elisp-scope-let* bindings body)) + +(elisp-scope-define-macro-analyzer nnoo-define-basics (&optional backend) + ;; Unsafe macro! + (let* ((bare (bare-symbol backend)) + (len (length (symbol-name bare))) + (beg (elisp-scope-sym-pos backend))) + (when beg (elisp-scope-report 'nnoo-backend beg len)))) + +(elisp-scope-define-macro-analyzer gv-define-expander (name handler) + (elisp-scope-gv-define-expander name handler)) + +(elisp-scope-define-macro-analyzer gv-define-simple-setter (name setter &rest rest) + (elisp-scope-gv-define-simple-setter name setter rest)) + +(elisp-scope-define-macro-analyzer cl-deftype (name arglist &rest body) + (elisp-scope-deftype name arglist body)) + +(elisp-scope-define-macro-analyzer define-minor-mode (&optional mode doc &rest body) + (when mode (elisp-scope-define-minor-mode mode doc body))) + +(elisp-scope-define-macro-analyzer setq-local (&rest args) + (elisp-scope-setq args)) + +(put 'setq-default 'elisp-scope-analyzer #'elisp-scope--analyze-setq-local) + +(elisp-scope-define-macro-analyzer cl-defun (name arglist &rest body) + (elisp-scope-cl-defun name arglist body)) + +(put 'cl-defmacro 'elisp-scope-analyzer #'elisp-scope--analyze-cl-defun) + +(elisp-scope-define-macro-analyzer defun (&optional name arglist &rest body) + (when name (elisp-scope-defun name arglist body))) + +(elisp-scope-define-macro-analyzer defmacro (&optional name arglist &rest body) + (elisp-scope-report-s name 'defmacro) + (elisp-scope-lambda arglist body)) + +(put 'ert-deftest 'elisp-scope-analyzer #'elisp-scope--analyze-defun) + +(elisp-scope-define-macro-analyzer elisp-scope-define-symbol-type (&optional name parents &rest props) + (elisp-scope-report-s name 'symbol-type-definition) + (dolist (parent parents) (elisp-scope-report-s parent 'symbol-type)) + (while-let ((kw (car-safe props)) + (bkw (elisp-scope-sym-bare kw)) + ((keywordp bkw))) + (elisp-scope-report-s kw 'constant) + (cl-case bkw + (:face + (if-let* ((q (elisp-scope--unquote (cadr props)))) (elisp-scope-face-1 q) + (elisp-scope-1 (cadr props)))) + (:definition + (if-let* ((q (elisp-scope--unquote (cadr props)))) + (dolist (st (ensure-list q)) (elisp-scope-report-s st 'symbol-type)) + (elisp-scope-1 (cadr props)))) + (otherwise (elisp-scope-1 (cadr props)))) + (setq props (cddr props)))) + +(elisp-scope-define-macro-analyzer cl-letf (bindings &rest body) + (let ((l elisp-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 (elisp-scope-sym-pos place))) + (when beg (elisp-scope-binding bare beg len)) + (setq l (elisp-scope-local-new bare beg l))) + (elisp-scope-1 place)) + (elisp-scope-1 (cadr binding)))) + (let ((elisp-scope--local l)) (elisp-scope-n body elisp-scope--output-type)))) + +(elisp-scope-define-macro-analyzer setf (&rest args) (elisp-scope-setq args)) + +(elisp-scope-define-macro-analyzer pop (&optional place) (elisp-scope-1 place)) + +(elisp-scope-define-macro-analyzer push (&optional newelt place) + (elisp-scope-1 newelt) + (elisp-scope-1 place)) + +(elisp-scope-define-macro-analyzer with-memoization (&optional place &rest body) + (elisp-scope-1 place) + (elisp-scope-n body elisp-scope--output-type)) + +(elisp-scope-define-macro-analyzer cl-pushnew (&rest args) + (mapc #'elisp-scope-1 args)) + +(dolist (sym '(incf decf)) + (put sym 'elisp-scope-analyzer #'elisp-scope--analyze-cl-pushnew)) + +(elisp-scope-define-macro-analyzer static-if (&optional test then &rest else) + (elisp-scope-1 test) + (elisp-scope-1 then elisp-scope--output-type) + (elisp-scope-n else elisp-scope--output-type)) + +(elisp-scope-define-macro-analyzer static-when (&optional test &rest body) + (elisp-scope-1 test) + (elisp-scope-n body elisp-scope--output-type)) + +(put 'static-unless 'elisp-scope-analyzer #'elisp-scope--analyze-static-when) + +(elisp-scope-define-macro-analyzer eval-when-compile (&rest body) + (elisp-scope-n body elisp-scope--output-type)) + +(put 'eval-and-compile 'elisp-scope-analyzer #'elisp-scope--analyze-eval-when-compile) + +(elisp-scope-define-macro-analyzer cl-callf (&rest args) + (elisp-scope-sharpquote (car args)) + (elisp-scope-n (cdr args))) + +(put 'cl-callf2 'elisp-scope-analyzer #'elisp-scope--analyze-cl-callf) + +(elisp-scope-define-macro-analyzer seq-let (args sequence &rest body) + (elisp-scope-1 sequence) + (let ((l elisp-scope--local)) + (dolist (arg args) + (let* ((bare (elisp-scope-sym-bare arg)) + (len (length (symbol-name bare))) + (beg (elisp-scope-sym-pos arg))) + (if (eq bare '&rest) + (elisp-scope-report 'ampersand beg len) + (when beg (elisp-scope-binding bare beg len)) + (setq l (elisp-scope-local-new bare beg l))))) + (let ((elisp-scope--local l)) (elisp-scope-n body)))) + +(elisp-scope-define-analyzer let-alist (f alist &rest body) + (elisp-scope-report-s f 'macro) + (elisp-scope-1 alist) + (let ((elisp-scope-current-let-alist-form + (cons (or (elisp-scope-sym-pos f) (cons 'gen (incf elisp-scope-counter))) + (elisp-scope-sym-pos f)))) + (elisp-scope-n body))) + +(elisp-scope-define-macro-analyzer define-obsolete-face-alias (&optional obs cur when) + (when-let* ((q (elisp-scope--unquote obs))) (elisp-scope-report-s q 'defface)) + (when-let* ((q (elisp-scope--unquote cur))) (elisp-scope-report-s q 'face)) + (elisp-scope-1 when)) + +(elisp-scope-define-macro-analyzer backquote (&optional structure) + (elisp-scope-backquote structure elisp-scope--output-type)) + +(defvar elisp-scope-backquote-depth 0) + +(defun elisp-scope-backquote (structure &optional outtype) + (let ((elisp-scope-backquote-depth (1+ elisp-scope-backquote-depth))) + (elisp-scope-backquote-1 structure outtype))) + +(defun elisp-scope-backquote-1 (structure &optional outtype) + (cond + ((vectorp structure) + (dotimes (i (length structure)) + (elisp-scope-backquote-1 (aref structure i)))) + ((atom structure) (elisp-scope-quote structure outtype)) + ((or (eq (car structure) backquote-unquote-symbol) + (eq (car structure) backquote-splice-symbol)) + (if (= elisp-scope-backquote-depth 1) + (elisp-scope-1 (cadr structure) outtype) + (let ((elisp-scope-backquote-depth (1- elisp-scope-backquote-depth))) + (elisp-scope-backquote-1 (cadr structure))))) + (t + (while (consp structure) (elisp-scope-backquote-1 (pop structure))) + (when structure (elisp-scope-backquote-1 structure))))) + +(elisp-scope-define-special-form-analyzer let (bindings &rest body) + (elisp-scope-let bindings body)) + +(elisp-scope-define-special-form-analyzer let* (bindings &rest body) + (elisp-scope-let* bindings body)) + +(elisp-scope-define-special-form-analyzer cond (&rest clauses) + (dolist (clause clauses) (elisp-scope-n clause elisp-scope--output-type))) + +(elisp-scope-define-special-form-analyzer setq (&rest args) + (elisp-scope-setq args)) + +(elisp-scope-define-special-form-analyzer defvar (&optional sym init _doc) + (elisp-scope-report-s sym 'defvar) + (elisp-scope-1 init)) + +(put 'defconst 'elisp-scope-analyzer #'elisp-scope--analyze-defvar) + +(defun elisp-scope-condition-case (var bodyform handlers) + (let* ((bare (bare-symbol var)) + (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) + (l (elisp-scope-local-new bare beg elisp-scope--local))) + (when beg (elisp-scope-binding bare beg (length (symbol-name bare)))) + (elisp-scope-1 bodyform elisp-scope--output-type) + (dolist (handler handlers) + (dolist (cond-name (ensure-list (car-safe handler))) + (when-let* ((cbeg (elisp-scope-sym-pos cond-name)) + (cbare (elisp-scope-sym-bare cond-name)) + (clen (length (symbol-name cbare)))) + (cond + ((booleanp cbare)) + ((keywordp cbare) (elisp-scope-report 'constant cbeg clen)) + (t (elisp-scope-report 'condition cbeg clen))))) + (let ((elisp-scope--local l)) + (elisp-scope-n (cdr handler) elisp-scope--output-type))))) + +(elisp-scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) + (elisp-scope-condition-case var bodyform handlers)) + +(elisp-scope-define-macro-analyzer condition-case-unless-debug (var bodyform &rest handlers) + (elisp-scope-condition-case var bodyform handlers)) + +(elisp-scope-define-special-form-analyzer function (&optional arg) + (when arg (elisp-scope-sharpquote arg))) + +(elisp-scope-define-special-form-analyzer quote (arg) + (elisp-scope-quote arg elisp-scope--output-type)) + +(elisp-scope-define-special-form-analyzer if (&optional test then &rest else) + (elisp-scope-1 test) + (elisp-scope-1 then elisp-scope--output-type) + (elisp-scope-n else elisp-scope--output-type)) + +(elisp-scope-define-special-form-analyzer and (&rest forms) + (elisp-scope-n forms elisp-scope--output-type)) + +(elisp-scope-define-special-form-analyzer or (&rest forms) + (dolist (form forms) (elisp-scope-1 form elisp-scope--output-type))) + +(defun elisp-scope-quote (arg &optional outtype) + (when outtype + (when-let* ((type (elisp-scope--match-type-to-arg outtype arg))) + (elisp-scope--handle-quoted type arg)))) + +(cl-defgeneric elisp-scope--handle-quoted (type arg)) + +(cl-defmethod elisp-scope--handle-quoted ((_type (eql t)) _arg) + ;; Do nothing. + ) + +(cl-defmethod elisp-scope--handle-quoted ((_type (eql 'code)) arg) + (let ((elisp-scope--local nil) + (elisp-scope-current-let-alist-form nil) + (elisp-scope-flet-alist nil) + (elisp-scope-block-alist nil) + (elisp-scope-macrolet-alist nil) + (elisp-scope-label-alist nil) + (elisp-scope-rx-alist nil) + (elisp-scope--quoted t)) + (elisp-scope-1 arg))) + +(cl-defmethod elisp-scope--handle-quoted ((type (head symbol)) arg) + (elisp-scope-report-s arg (cdr type))) + +(cl-defmethod elisp-scope--handle-quoted ((type (head list)) arg) + (let ((types (cdr type))) + (while types (elisp-scope--handle-quoted (pop types) (pop arg))))) + +(cl-defmethod elisp-scope--handle-quoted ((type (head cons)) arg) + (elisp-scope--handle-quoted (cadr type) (car arg)) + (elisp-scope--handle-quoted (cddr type) (cdr arg))) + +(cl-defgeneric elisp-scope--match-type-to-arg (type arg)) + +(cl-defmethod elisp-scope--match-type-to-arg ((type (eql 'code)) _arg) type) + +(cl-defmethod elisp-scope--match-type-to-arg ((_type (eql 'type)) arg) + (elisp-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 elisp-scope--match-type-to-arg ((type (head symbol)) arg) + (when (or (symbolp arg) (symbol-with-pos-p arg)) type)) + +(cl-defmethod elisp-scope--match-type-to-arg ((type (head repeat)) arg) + (when (listp arg) + (named-let loop ((args arg) (acc nil)) + (if args + (when-let* ((res (elisp-scope--match-type-to-arg (cdr type) (car args)))) + (loop (cdr args) (cons res acc))) + (cons 'list (nreverse acc)))))) + +(cl-defmethod elisp-scope--match-type-to-arg ((type (head or)) arg) + (named-let loop ((types (cdr type))) + (when types + (if-let* ((res (elisp-scope--match-type-to-arg (car types) arg))) res + (loop (cdr types)))))) + +(cl-defmethod elisp-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 (elisp-scope--match-type-to-arg car-type (car arg))) + (cdr-res (elisp-scope--match-type-to-arg cdr-type (cdr arg)))) + (cons 'cons (cons car-res cdr-res)))))) + +(cl-defmethod elisp-scope--match-type-to-arg ((type (head equal)) arg) + (equal (cdr type) arg)) + +(elisp-scope--match-type-to-arg '(repeat . + (or (cons (equal . foo) . (symbol footype)) + (cons (equal . bar) . (symbol bartype)))) + '((bar . spambar) (foo . spamfoo))) + +(elisp-scope-define-special-form-analyzer catch (&optional tag &rest body) + (elisp-scope-1 tag '(symbol . throw-tag)) + (elisp-scope-n body elisp-scope--output-type)) + +(elisp-scope-define-special-form-analyzer progn (&rest body) + (elisp-scope-n body elisp-scope--output-type)) + +(put 'inline 'elisp-scope-analyzer #'elisp-scope--analyze-progn) +(put 'save-current-buffer 'elisp-scope-analyzer #'elisp-scope--analyze-progn) +(put 'save-excursion 'elisp-scope-analyzer #'elisp-scope--analyze-progn) +(put 'save-restriction 'elisp-scope-analyzer #'elisp-scope--analyze-progn) + +(elisp-scope-define-special-form-analyzer while (&rest rest) + (mapc #'elisp-scope-1 rest)) + +(elisp-scope-define-special-form-analyzer prog1 (&rest body) + (when (consp body) (elisp-scope-1 (pop body) elisp-scope--output-type)) + (elisp-scope-n body)) + +(put 'unwind-protect 'elisp-scope-analyzer #'elisp-scope--analyze-prog1) + +(defun elisp-scope-report-s (sym type) + (when-let* ((beg (elisp-scope-sym-pos sym)) (bare (bare-symbol sym))) + (elisp-scope-report type beg (length (symbol-name bare))))) + +(defvar-local elisp-scope-buffer-file-name nil) + +(defun elisp-scope-1 (form &optional outtype) + (cond + ((consp form) + (let* ((f (car form)) (bare (elisp-scope-sym-bare f)) + (forms (cdr form)) (this nil)) + (when bare + (cond + ((setq this (assq bare elisp-scope-flet-alist)) + (elisp-scope-report + 'function (symbol-with-pos-pos f) (length (symbol-name bare)) (cdr this)) + (elisp-scope-n forms)) + ((setq this (assq bare elisp-scope-macrolet-alist)) + (when (symbol-with-pos-p f) + (elisp-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 'elisp-scope-analyzer)) + (let ((elisp-scope--output-type outtype)) (apply this form))) + ((special-form-p bare) (elisp-scope-report-s f 'special-form) (elisp-scope-n forms)) + ((macrop bare) (elisp-scope-report-s f 'macro) + (cond + ((eq (get bare 'edebug-form-spec) t) (elisp-scope-n forms)) + ((elisp-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 elisp-scope-unsafe-macros) macroexpand-all-environment)) + (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) + (elisp-scope-1 expanded))))) + ((or (functionp bare) (memq bare elisp-scope-local-functions)) + (elisp-scope-report-s f 'function) (elisp-scope-n forms)) + (t + (elisp-scope-report-s f 'unknown) + (when elisp-scope-assume-func (elisp-scope-n forms))))))) + ((symbol-with-pos-p form) (elisp-scope-s form)))) + +(defun elisp-scope-n (body &optional outtype) + (while (cdr-safe body) (elisp-scope-1 (pop body))) + (when-let* ((form (car-safe body))) (elisp-scope-1 form outtype))) + +;;;###autoload +(defun elisp-scope-analyze-form (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 ((elisp-scope-counter 0) + (elisp-scope-callback callback) + (read-symbol-shorthands nil) + (max-lisp-eval-depth 32768)) + (elisp-scope-1 (read-positioning-symbols (or stream (current-buffer)))))) + +(provide 'elisp-scope) +;;; elisp-scope.el ends here diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el deleted file mode 100644 index 2791e362eb9..00000000000 --- a/lisp/emacs-lisp/scope.el +++ /dev/null @@ -1,2666 +0,0 @@ -;;; 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 static-when static-unless - 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 static-when (&optional test &rest body) - (scope-1 test) - (scope-n body scope--output-type)) - -(put 'static-unless 'scope-analyzer #'scope--analyze-static-when) - -(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 cca9a4aef73..d35bddc1a45 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -434,7 +434,7 @@ the role of each symbol and highlight it accordingly." (save-excursion (goto-char pos) (beginning-of-defun) - (scope (lambda (_type beg len id &optional _def) + (elisp-scope-analyze-form (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)))))) @@ -491,7 +491,7 @@ the role of each symbol and highlight it accordingly." (when elisp-add-help-echo (put-text-property beg end 'help-echo - (when-let* ((fun (scope-get-symbol-type-property type :help))) + (when-let* ((fun (elisp-scope-get-symbol-type-property type :help))) (funcall fun beg end def))))) (defvar font-lock-beg) @@ -524,7 +524,7 @@ that `font-lock-keywords' applied takes precedence, if any." (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))) + (let ((face (elisp-scope-get-symbol-type-property type :face))) (add-face-text-property beg end face (cl-case elisp-fontify-symbol-precedence-function @@ -543,7 +543,8 @@ that `font-lock-keywords' applied takes precedence, if any." "Fontify symbols between BEG and END according to their semantics." (save-excursion (goto-char beg) - (while (< (point) end) (ignore-errors (scope #'elisp-fontify-symbol))))) + (while (< (point) end) + (ignore-errors (elisp-scope-analyze-form #'elisp-fontify-symbol))))) (defun elisp-fontify-region (beg end &optional loudly) "Fontify ELisp code between BEG and END. commit 761e706505872cbaa135da131ab812a92385a896 Author: Eshel Yaron Date: Mon Sep 29 16:40:56 2025 +0200 ; scope.el: Mark 'static-when/unless' as unsafe. * lisp/emacs-lisp/scope.el: Add handlers for 'static-when' and 'static-unless'. (scope-unsafe-macros): Also add them to list of unsafe macros. diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index f33b5ff403c..2791e362eb9 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -1608,7 +1608,8 @@ trusted code macro expansion is always safe." :group 'lisp) (defvar scope-unsafe-macros - '( static-if cl-eval-when eval-when-compile eval-and-compile let-when-compile + '( static-if static-when static-unless + cl-eval-when eval-when-compile eval-and-compile let-when-compile rx cl-macrolet nnoo-define-basics)) (defun scope-safe-macro-p (macro) @@ -2356,6 +2357,12 @@ trusted code macro expansion is always safe." (scope-1 then scope--output-type) (scope-n else scope--output-type)) +(scope-define-macro-analyzer static-when (&optional test &rest body) + (scope-1 test) + (scope-n body scope--output-type)) + +(put 'static-unless 'scope-analyzer #'scope--analyze-static-when) + (scope-define-macro-analyzer eval-when-compile (&rest body) (scope-n body scope--output-type)) commit 136c39438f73066167c6597c67d62a5ea3565230 Author: Eshel Yaron Date: Sun Sep 28 09:58:28 2025 +0200 Add optional semantic highlighting for Emacs Lisp. * lisp/emacs-lisp/scope.el: New file. * lisp/progmodes/elisp-mode.el (elisp): New 'defgroup'. (elisp-add-help-echo, elisp-fontify-semantically) (elisp-fontify-symbol-precedence-function): New options. (elisp-symbol-at-mouse, elisp-free-variable, elisp-condition) (elisp-major-mode-name, elisp-face, elisp-symbol-type) (elisp-symbol-type-definition, elisp-function-reference) (elisp-non-local-exit, elisp-unknown-call, elisp-macro-call) (elisp-special-form, elisp-throw-tag, elisp-feature) (elisp-rx, elisp-theme, elisp-binding-variable) (elisp-bound-variable, elisp-shadowing-variable) (elisp-shadowed-variable, elisp-variable-at-point) (elisp-warning-type, elisp-declaration, elisp-thing) (elisp-slot, elisp-widget-type, elisp-type, elisp-group) (elisp-nnoo-backend, elisp-ampersand, elisp-constant) (elisp-defun, elisp-defmacro, elisp-defvar, elisp-defface) (elisp-icon, elisp-deficon, elisp-oclosure) (elisp-defoclosure, elisp-coding, elisp-defcoding) (elisp-charset, elisp-defcharset, elisp-completion-category) (elisp-completion-category-definition): New faces. (elisp-local-references, elisp-highlight-variable) (elisp-unhighlight-variable, elisp-cursor-sensor) (elisp--function-help-echo, elisp--help-echo-1) (elisp--help-echo, elisp--annotate-symbol-with-help-echo) (elisp-extend-region-to-whole-defuns, elisp-fontify-symbol) (elisp-fontify-region-semantically, elisp-fontify-region): New functions. (emacs-lisp-mode): Set 'font-lock-extra-managed-props', 'font-lock-fontify-region-function' and 'font-lock-extend-region-functions'. * etc/NEWS: Announce new feature. 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