From 29c47ac19a393d2544562fe8932bc4e1b6ddd7c9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 10 Feb 2021 16:06:24 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Break cycles * test/lisp/emacs-lisp/macroexp-tests.el: New file. --- lisp/emacs-lisp/macroexp.el | 43 +++++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 14 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 042061c44fc..13ff5ef2eda 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -572,20 +572,35 @@ test of free variables in the following ways: - For the same reason it may cause the result to fail to include bindings which will be used if SEXP is not yet fully macro-expanded and the use of the binding will only be revealed by macro expansion." - (let ((res '())) - (while (and (consp sexp) bindings) - (dolist (binding (macroexp--fgrep bindings (pop sexp))) - (push binding res) - (setq bindings (remove binding bindings)))) - (if (or (vectorp sexp) (byte-code-function-p sexp)) - ;; With backquote, code can appear within vectors as well. - ;; This wouldn't be needed if we `macroexpand-all' before - ;; calling macroexp--fgrep, OTOH. - (macroexp--fgrep bindings (mapcar #'identity sexp)) - (let ((tmp (assq sexp bindings))) - (if tmp - (cons tmp res) - res))))) + (let ((res '()) + ;; Cyclic code should not happen, but code can contain cyclic data :-( + (seen (make-hash-table :test #'eq)) + (sexpss (list (list sexp)))) + ;; Use a nested while loop to reduce the amount of heap allocations for + ;; pushes to `sexpss' and the `gethash' overhead. + (while (and sexpss bindings) + (let ((sexps (pop sexpss))) + (unless (gethash sexps seen) + (puthash sexps t seen) ;; Using `setf' here causes bootstrap problems. + (if (vectorp sexps) (setq sexps (mapcar #'identity sexps))) + (let ((tortoise sexps) (skip t)) + (while sexps + (let ((sexp (if (consp sexps) (pop sexps) + (prog1 sexps (setq sexps nil))))) + (if skip + (setq skip nil) + (setq tortoise (cdr tortoise)) + (if (eq tortoise sexps) + (setq sexps nil) ;; Found a cycle: we're done! + (setq skip t))) + (cond + ((or (consp sexp) (vectorp sexp)) (push sexp sexpss)) + (t + (let ((tmp (assq sexp bindings))) + (when tmp + (push tmp res) + (setq bindings (remove tmp bindings)))))))))))) + res)) ;;; Load-time macro-expansion. -- cgit v1.2.3 From 3a4b65177f0c26f342e657636ce62e8c16cbb14b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 11 Feb 2021 19:06:30 -0500 Subject: * lisp/emacs-lisp/gv.el (gv-place): Simplify --- lisp/emacs-lisp/gv.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 29f8230e6b8..c160aa1fd35 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -307,7 +307,7 @@ The return value is the last VAL in the list. ;; Autoload this `put' since a user might use C-u C-M-x on an expression ;; containing a non-trivial `push' even before gv.el was loaded. ;;;###autoload -(put 'gv-place 'edebug-form-spec 'edebug-match-form) +(put 'gv-place 'edebug-form-spec '(form)) ;So-called "indirect spec". ;; CL did the equivalent of: ;;(gv-define-macroexpand edebug-after (lambda (before index place) place)) -- cgit v1.2.3 From 1d2487b1fc5f0648deb80507be8c713d4482fd8d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 11:12:49 -0500 Subject: * lisp/emacs-lisp/edebug.el: Misc cleanups. Move all definitions under the `edebug-` prefix. (edebug-get-spec): Rename from `get-edebug-spec`. (edebug-move-cursor): Use `cl-callf`. (edebug-spec-p): Remove unused function. (def-edebug-spec, edebug-spec-list, edebug-spec): Remove unused specs (nothing in there gets instrumented anyway). (edebug-tracing): Use `declare`. (edebug-cancel-on-entry): Rename from `cancel-edebug-on-entry`. (edebug-global-prefix): Rename from `global-edebug-prefix`. (edebug-global-map): Rename from `global-edebug-map`. * lisp/emacs-lisp/pcase.el (pcase-PAT): Remove `let`. (let): Use `declare` instead. (pcase--edebug-match-macro): Use new name `edebug-get-spec`. --- etc/NEWS | 3 ++ lisp/emacs-lisp/edebug.el | 101 ++++++++++++++++++++++------------------------ lisp/emacs-lisp/pcase.el | 30 +++++++------- 3 files changed, 65 insertions(+), 69 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 9a9c75f0f8c..228b773cb27 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -935,6 +935,9 @@ To customize obsolete user options, use 'customize-option' or ** Edebug +--- +*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. + +++ *** Edebug specification lists can use the new keyword '&error', which unconditionally aborts the current edebug instrumentation with the diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 0733dcec27b..04a4829c5e6 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -244,19 +244,22 @@ If the result is non-nil, then break. Errors are ignored." ;;; Form spec utilities. -(defun get-edebug-spec (symbol) +(defun edebug-get-spec (symbol) + "Return the Edebug spec of a given Lisp expression's head SYMBOL. +The argument is usually a symbol, but it doesn't have to be." ;; Get the spec of symbol resolving all indirection. (let ((spec nil) (indirect symbol)) (while - (progn - (and (symbolp indirect) - (setq indirect - (function-get indirect 'edebug-form-spec 'macro)))) + (and (symbolp indirect) + (setq indirect + (function-get indirect 'edebug-form-spec 'macro))) ;; (edebug-trace "indirection: %s" edebug-form-spec) (setq spec indirect)) spec)) +(define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1") + ;;;###autoload (defun edebug-basic-spec (spec) "Return t if SPEC uses only extant spec symbols. @@ -961,6 +964,18 @@ circular objects. Let `read' read everything else." ;;; Cursors for traversal of list and vector elements with offsets. +;; Edebug's instrumentation is based on parsing the sexps, which come with +;; auxiliary position information. Instead of keeping the position +;; information together with the sexps, it is kept in a "parallel +;; tree" of offsets. +;; +;; An "edebug cursor" is a pair of a *list of sexps* (called the +;; "expressions") together with a matching list of offsets. +;; When we're parsing the content of a list, the +;; `edebug-cursor-expressions' is simply the list but when parsing +;; a vector, the `edebug-cursor-expressions' is a list formed of the +;; elements of the vector. + (defvar edebug-dotted-spec nil "Set to t when matching after the dot in a dotted spec list.") @@ -1015,8 +1030,8 @@ circular objects. Let `read' read everything else." ;; The following test should always fail. (if (edebug-empty-cursor cursor) (edebug-no-match cursor "Not enough arguments.")) - (setcar cursor (cdr (car cursor))) - (setcdr cursor (cdr (cdr cursor))) + (cl-callf cdr (car cursor)) + (cl-callf cdr (cdr cursor)) cursor) @@ -1153,7 +1168,7 @@ purpose by adding an entry to this alist, and setting (eq 'symbol (progn (forward-char 1) (edebug-next-token-class)))) ;; Find out if this is a defining form from first symbol (setq def-kind (read (current-buffer)) - spec (and (symbolp def-kind) (get-edebug-spec def-kind)) + spec (and (symbolp def-kind) (edebug-get-spec def-kind)) defining-form-p (and (listp spec) (eq '&define (car spec))) ;; This is incorrect in general!! But OK most of the time. @@ -1502,7 +1517,7 @@ contains a circular object." (if (eq 'quote (car form)) form (let* ((head (car form)) - (spec (and (symbolp head) (get-edebug-spec head))) + (spec (and (symbolp head) (edebug-get-spec head))) (new-cursor (edebug-new-cursor form offset))) ;; Find out if this is a defining form from first symbol. ;; An indirect spec would not work here, yet. @@ -1542,7 +1557,7 @@ contains a circular object." (defsubst edebug-list-form-args (head cursor) ;; Process the arguments of a list form given that head of form is a symbol. ;; Helper for edebug-list-form - (let ((spec (get-edebug-spec head))) + (let ((spec (edebug-get-spec head))) (cond ;; Treat cl-macrolet bindings like macros with no spec. ((member head edebug--cl-macrolet-defs) @@ -1645,7 +1660,7 @@ contains a circular object." edebug-error-point (edebug-gate edebug-gate) ;; locally bound to limit effect ) - (edebug-match-specs cursor specs 'edebug-match-specs))) + (edebug-match-specs cursor specs #'edebug-match-specs))) (defun edebug-match-one-spec (cursor spec) @@ -1741,11 +1756,16 @@ contains a circular object." (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. )) + ;; FIXME: We abuse `edebug-form-spec' here. It's normally used to store the + ;; specs for a given sexp's head, but here we use it to keep the + ;; function implementing of a given "core spec". (put (car pair) 'edebug-form-spec (cdr pair))) (defun edebug-match-symbol (cursor symbol) ;; Match a symbol spec. - (let* ((spec (get-edebug-spec symbol))) + ;; FIXME: We abuse `edebug-get-spec' here, passing it a *spec* rather than + ;; the head element of a source sexp. + (let* ((spec (edebug-get-spec symbol))) (cond (spec (if (consp spec) @@ -2000,7 +2020,7 @@ contains a circular object." cursor "Expected lambda expression")) (offset (edebug-top-offset cursor)) (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (get-edebug-spec head))) + (spec (and (symbolp head) (edebug-get-spec head))) (edebug-inside-func nil)) ;; Find out if this is a defining form from first symbol. (if (and (consp spec) (eq '&define (car spec))) @@ -2145,37 +2165,6 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;;;; Edebug Form Specs ;;; ========================================================== -;;;;* Spec for def-edebug-spec -;;; Out of date. - -(defun edebug-spec-p (object) - "Return non-nil if OBJECT is a symbol with an edebug-form-spec property." - (and (symbolp object) - (get object 'edebug-form-spec))) - -(def-edebug-spec def-edebug-spec - ;; Top level is different from lower levels. - (&define :name edebug-spec name - &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec))) - -(def-edebug-spec edebug-spec-list - ;; A list must have something in it, or it is nil, a symbolp - ((edebug-spec . [&or nil edebug-spec]))) - -(def-edebug-spec edebug-spec - (&or - edebug-spec-list - (vector &rest edebug-spec) ; matches a vector - ("vector" &rest edebug-spec) ; matches a vector spec - ("quote" symbolp) - stringp - [edebug-lambda-list-keywordp &rest edebug-spec] - [keywordp gate edebug-spec] - edebug-spec-p ;; Including all the special ones e.g. form. - symbolp;; a predicate - )) - - ;;;* Emacs special forms and some functions. ;; quote expects only one argument, although it allows any number. @@ -2485,11 +2474,10 @@ STATUS should be a list returned by `edebug-var-status'." (edebug-print-trace-after (format "%s result: %s" function edebug-result))))) -(def-edebug-spec edebug-tracing (form body)) - (defmacro edebug-tracing (msg &rest body) "Print MSG in *edebug-trace* before and after evaluating BODY. The result of BODY is also printed." + (declare (debug (form body))) `(let ((edebug-stack-depth (1+ edebug-stack-depth)) edebug-result) (edebug-print-trace-before ,msg) @@ -3601,7 +3589,10 @@ canceled the first time the function is entered." ;; Could store this in the edebug data instead. (put function 'edebug-on-entry (if flag 'temp t))) -(defalias 'edebug-cancel-edebug-on-entry #'cancel-edebug-on-entry) +(define-obsolete-function-alias 'edebug-cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") +(define-obsolete-function-alias 'cancel-edebug-on-entry + #'edebug-cancel-on-entry "28.1") (defun edebug--edebug-on-entry-functions () (let ((functions nil)) @@ -3613,7 +3604,7 @@ canceled the first time the function is entered." obarray) functions)) -(defun cancel-edebug-on-entry (function) +(defun edebug-cancel-on-entry (function) "Cause Edebug to not stop when FUNCTION is called. The removes the effect of `edebug-on-entry'. If FUNCTION is is nil, remove `edebug-on-entry' on all functions." @@ -3937,10 +3928,14 @@ be installed in `emacs-lisp-mode-map'.") ;; Autoloading these global bindings doesn't make sense because ;; they cannot be used anyway unless Edebug is already loaded and active. -(defvar global-edebug-prefix "\^XX" +(define-obsolete-variable-alias 'global-edebug-prefix + 'edebug-global-prefix "28.1") +(defvar edebug-global-prefix "\^XX" "Prefix key for global edebug commands, available from any buffer.") -(defvar global-edebug-map +(define-obsolete-variable-alias 'global-edebug-map + 'edebug-global-map "28.1") +(defvar edebug-global-map (let ((map (make-sparse-keymap))) (define-key map " " 'edebug-step-mode) @@ -3973,9 +3968,9 @@ be installed in `emacs-lisp-mode-map'.") map) "Global map of edebug commands, available from any buffer.") -(when global-edebug-prefix - (global-unset-key global-edebug-prefix) - (global-set-key global-edebug-prefix global-edebug-map)) +(when edebug-global-prefix + (global-unset-key edebug-global-prefix) + (global-set-key edebug-global-prefix edebug-global-map)) (defun edebug-help () diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index ec746fa4747..7a88bdf8de5 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -27,19 +27,10 @@ ;; Todo: -;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't -;; use x, because x is bound separately for the equality constraint -;; (as well as any pred/guard) and for the body, so uses at one place don't -;; count for the other. -;; - provide ways to extend the set of primitives, with some kind of -;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) -;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). -;; But better would be if we could define new ways to match by having the -;; extension provide its own `pcase--split-' thingy. -;; - along these lines, provide patterns to match CL structs. +;; - Allow to provide new `pcase--split-' thingy. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases +;; - provide a way to continue matching to subsequent cases ;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and ;; to reduce the number of leaves that need to be turned into functions: @@ -77,7 +68,6 @@ ("or" &rest pcase-PAT) ("and" &rest pcase-PAT) ("guard" form) - ("let" pcase-PAT form) ("pred" pcase-FUN) ("app" pcase-FUN pcase-PAT) pcase-MACRO @@ -91,10 +81,10 @@ sexp)) ;; See bug#24717 -(put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro) +(put 'pcase-MACRO 'edebug-form-spec #'pcase--edebug-match-macro) ;; Only called from edebug. -(declare-function get-edebug-spec "edebug" (symbol)) +(declare-function edebug-get-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) (defun pcase--get-macroexpander (s) @@ -106,13 +96,15 @@ (mapatoms (lambda (s) (let ((m (pcase--get-macroexpander s))) - (when (and m (get-edebug-spec m)) - (push (cons (symbol-name s) (get-edebug-spec m)) + (when (and m (edebug-get-spec m)) + (push (cons (symbol-name s) (edebug-get-spec m)) specs))))) (edebug-match cursor (cons '&or specs)))) ;;;###autoload (defmacro pcase (exp &rest cases) + ;; FIXME: Add some "global pattern" to wrap every case? + ;; Could be used to wrap all cases in a ` "Evaluate EXP to get EXPVAL; try passing control to one of CASES. CASES is a list of elements of the form (PATTERN CODE...). For the first CASE whose PATTERN \"matches\" EXPVAL, @@ -1002,7 +994,13 @@ The predicate is the logical-AND of: (pcase-defmacro let (pat expr) "Matches if EXPR matches PAT." + (declare (debug (pcase-PAT form))) `(app (lambda (_) ,expr) ,pat)) +;; (pcase-defmacro guard (expr) +;; "Matches if EXPR is non-nil." +;; (declare (debug (form))) +;; `(pred (lambda (_) ,expr))) + (provide 'pcase) ;;; pcase.el ends here -- cgit v1.2.3 From 6ae731e04f261b9139fbe3573822a381dc3577d3 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 11:37:49 -0500 Subject: * lisp/emacs-lisp/cl-macs.el (cl-flet): Fix edebug spec --- lisp/emacs-lisp/cl-macs.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c2bf02ccece..c312afe55b9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2016,7 +2016,7 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name :unique "cl-flet@" function-form) + (debug ((&rest [&or (&define name :unique "cl-flet@" form) (&define name :unique "cl-flet@" cl-lambda-list cl-declarations-or-string -- cgit v1.2.3 From c7b35ea3060b90ed68a933eed29e85dd2d567e3e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 12:17:40 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug--handle-&-spec-op) <&lookup>: New method * doc/lispref/edebug.texi (Specification List): Document it. * lisp/emacs-lisp/pcase.el (pcase-PAT): Use it. (pcase-MACRO): Remove Edebug element. (pcase--get-edebug-spec): New function. (pcase--edebug-match-macro): Remove function. --- doc/lispref/edebug.texi | 11 +++++++++++ etc/NEWS | 15 +++++++++------ lisp/emacs-lisp/edebug.el | 17 +++++++++++++++++ lisp/emacs-lisp/pcase.el | 40 +++++++++++++--------------------------- 4 files changed, 50 insertions(+), 33 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 569545d83f1..693d0e0630a 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1370,6 +1370,17 @@ is primarily used to generate more specific syntax error messages. See edebug-spec; it aborts the instrumentation, displaying the message in the minibuffer. +@item &lookup +Selects a specification based on the code being instrumented. +It takes the form @code{&lookup @var{spec} @var{fun} @var{args...}} +and means that Edebug will first match @var{spec} against the code and +then match the rest against the specification returned by calling +@var{fun} with the concatenation of @var{args...} and the code that +matched @code{spec}. For example @code{(&lookup symbolp +pcase--get-edebug-spec)} matches sexps whose first element is +a symbol and whose subsequent elements must obey the spec associated +with that head symbol according to @code{pcase--get-edebug-spec}. + @item @var{other-symbol} @cindex indirect specifications Any other symbol in a specification list may be a predicate or an diff --git a/etc/NEWS b/etc/NEWS index 228b773cb27..fe626fec7ec 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -938,14 +938,17 @@ To customize obsolete user options, use 'customize-option' or --- *** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. +*** Edebug specification lists can use some new keywords: + ++++ +**** '&lookup SPEC FUN ARGS...' lets FUN compute the specs to use + +++ -*** Edebug specification lists can use the new keyword '&error', which -unconditionally aborts the current edebug instrumentation with the -supplied error message. +**** '&error MSG' unconditionally aborts the current edebug instrumentation. -*** Edebug specification lists can use the new keyword ':unique', -which appends a unique suffix to the Edebug name of the current -definition. ++++ +**** ':unique STRING' appends STRING to the Edebug name of the current +definition to (hopefully) make it more unique. ** ElDoc diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 04a4829c5e6..782299454ea 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -55,6 +55,7 @@ (require 'backtrace) (require 'macroexp) (require 'cl-lib) +(require 'seq) (eval-when-compile (require 'pcase)) ;;; Options @@ -1866,6 +1867,22 @@ contains a circular object." (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) +(cl-defmethod edebug--handle-&-spec-op ((_ (eql &lookup)) cursor specs) + "Compute the specs for `&lookup SPEC FUN ARGS...'. +Extracts the head of the data by matching it against SPEC, +and then matches the rest against the output of (FUN ARGS... HEAD)." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (exps (edebug-cursor-expressions cursor)) + (instrumented-head (edebug-match-one-spec cursor (or spec 'sexp))) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (newspecs (apply fun (append args (seq-subseq exps 0 consumed))))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + ;; FIXME: What'd be the difference if we used `edebug-match-sublist', + ;; which is what `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs)))) (cl-defmethod edebug--handle-&-spec-op ((_ (eql ¬)) cursor specs) ;; If any specs match, then fail diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7a88bdf8de5..d6c96c1ec82 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -62,45 +62,32 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) -(def-edebug-spec - pcase-PAT - (&or symbolp - ("or" &rest pcase-PAT) - ("and" &rest pcase-PAT) - ("guard" form) - ("pred" pcase-FUN) - ("app" pcase-FUN pcase-PAT) - pcase-MACRO +(def-edebug-spec pcase-PAT + (&or (&lookup symbolp pcase--get-edebug-spec) sexp)) -(def-edebug-spec - pcase-FUN +(def-edebug-spec pcase-FUN (&or lambda-expr ;; Punt on macros/special forms. (functionp &rest form) sexp)) -;; See bug#24717 -(put 'pcase-MACRO 'edebug-form-spec #'pcase--edebug-match-macro) - ;; Only called from edebug. (declare-function edebug-get-spec "edebug" (symbol)) -(declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-edebug-spec (head) + (or (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (and me (symbolp me) (edebug-get-spec me))))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil" (get s 'pcase-macroexpander)) -(defun pcase--edebug-match-macro (cursor) - (let (specs) - (mapatoms - (lambda (s) - (let ((m (pcase--get-macroexpander s))) - (when (and m (edebug-get-spec m)) - (push (cons (symbol-name s) (edebug-get-spec m)) - specs))))) - (edebug-match cursor (cons '&or specs)))) - ;;;###autoload (defmacro pcase (exp &rest cases) ;; FIXME: Add some "global pattern" to wrap every case? @@ -938,8 +925,7 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Unknown pattern `%S'" upat))))) (t (error "Incorrect MATCH %S" (car matches))))) -(def-edebug-spec - pcase-QPAT +(def-edebug-spec pcase-QPAT ;; Cf. edebug spec for `backquote-form' in edebug.el. (&or ("," pcase-PAT) (pcase-QPAT [&rest [¬ ","] pcase-QPAT] -- cgit v1.2.3 From ea29908c1870417eba98f27525a6f2f571d65396 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Thu, 11 Feb 2021 17:34:17 +0100 Subject: Avoid traversing dead `if` branches in bytecode optimiser There is no point in traversing conditional branches that are statically known never to be executed. This saves some optimisation effort, but more importantly prevents variable assignments and references in those branches from blocking effective constant propagation. Also attempt to traverse as much as possible in an unconditional context, which enables constant-propagation through (linear) assignments. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form): Rewrite the (tail) recursion into an explicit loop. Normalise a return value of (quote nil) to nil, for easier subsequent optimisations. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Don't traverse dead `if` branches. Use unconditional traversion context when possible. --- lisp/emacs-lisp/byte-opt.el | 64 ++++++++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 32 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 8851f0ef32d..fec3407782e 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -458,16 +458,22 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (cons fn (byte-optimize-body exps for-effect))) (`(if ,test ,then . ,else) + ;; FIXME: We are conservative here: any variable changed in the + ;; THEN branch will be barred from substitution in the ELSE + ;; branch, despite the branches being mutually exclusive. + ;; The test is always executed. (let* ((test-opt (byte-optimize-form test nil)) - ;; The THEN and ELSE branches are executed conditionally. - ;; - ;; FIXME: We are conservative here: any variable changed in the - ;; THEN branch will be barred from substitution in the ELSE - ;; branch, despite the branches being mutually exclusive. - (byte-optimize--vars-outside-condition byte-optimize--lexvars) - (then-opt (byte-optimize-form then for-effect)) - (else-opt (byte-optimize-body else for-effect))) + (const (macroexp-const-p test-opt)) + ;; The branches are traversed unconditionally when possible. + (byte-optimize--vars-outside-condition + (if const + byte-optimize--vars-outside-condition + byte-optimize--lexvars)) + ;; Avoid traversing dead branches. + (then-opt (and test-opt (byte-optimize-form then for-effect))) + (else-opt (and (not (and test-opt const)) + (byte-optimize-body else for-effect)))) `(if ,test-opt ,then-opt . ,else-opt))) (`(,(or 'and 'or) . ,exps) ; Remember, and/or are control structures. @@ -638,30 +644,24 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." - ;; - ;; First, optimize all sub-forms of this one. - (setq form (byte-optimize-form-code-walker form for-effect)) - ;; - ;; after optimizing all subforms, optimize this form until it doesn't - ;; optimize any further. This means that some forms will be passed through - ;; the optimizer many times, but that's necessary to make the for-effect - ;; processing do as much as possible. - ;; - (let (opt new) - (if (and (consp form) - (symbolp (car form)) - (or ;; (and for-effect - ;; ;; We don't have any of these yet, but we might. - ;; (setq opt (get (car form) - ;; 'byte-for-effect-optimizer))) - (setq opt (function-get (car form) 'byte-optimizer))) - (not (eq form (setq new (funcall opt form))))) - (progn -;; (if (equal form new) (error "bogus optimizer -- %s" opt)) - (byte-compile-log " %s\t==>\t%s" form new) - (setq new (byte-optimize-form new for-effect)) - new) - form))) + (while + (progn + ;; First, optimize all sub-forms of this one. + (setq form (byte-optimize-form-code-walker form for-effect)) + + ;; If a form-specific optimiser is available, run it and start over + ;; until a fixpoint has been reached. + (and (consp form) + (symbolp (car form)) + (let ((opt (function-get (car form) 'byte-optimizer))) + (and opt + (let ((old form) + (new (funcall opt form))) + (byte-compile-log " %s\t==>\t%s" old new) + (setq form new) + (not (eq new old)))))))) + ;; Normalise (quote nil) to nil, for a single representation of constant nil. + (and (not (equal form '(quote nil))) form)) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body -- cgit v1.2.3 From 5a11e9185c0416df8fa3a15bb0d60b6ba6827869 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 12 Feb 2021 19:41:07 +0100 Subject: byte-opt.el: More concise expression * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Refactor `setq` clause. --- lisp/emacs-lisp/byte-opt.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index fec3407782e..c383e0285b9 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -593,16 +593,15 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") (lexvar (assq var byte-optimize--lexvars)) (value (byte-optimize-form expr nil))) (when lexvar - ;; If it's bound outside conditional, invalidate. - (if (assq var byte-optimize--vars-outside-condition) - ;; We are in conditional code and the variable was - ;; bound outside: cancel substitutions. - (setcdr (cdr lexvar) nil) - ;; Set a new value (if substitutable). - (setcdr (cdr lexvar) - (and (byte-optimize--substitutable-p value) - (list value)))) - (setcar (cdr lexvar) t)) ; Mark variable to be kept. + ;; Set a new value or inhibit further substitution. + (setcdr (cdr lexvar) + (and + ;; Inhibit if bound outside conditional code. + (not (assq var byte-optimize--vars-outside-condition)) + ;; The new value must be substitutable. + (byte-optimize--substitutable-p value) + (list value))) + (setcar (cdr lexvar) t)) ; Mark variable to be kept. (push var var-expr-list) (push value var-expr-list)) (setq args (cddr args))) -- cgit v1.2.3 From 9518926220943d5c405e03d7352343341e07ba83 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Fri, 12 Feb 2021 19:43:41 +0100 Subject: Simplify expression in byte-code decompiler * lisp/emacs-lisp/byte-opt.el (byte-decompile-bytecode-1): Replace roundabout expression with what it essentially does. --- lisp/emacs-lisp/byte-opt.el | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c383e0285b9..e0feb95a461 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1562,10 +1562,7 @@ Same format as `byte-optimize--lexvars', with shared structure and contents.") ;; so we create a copy of it, and replace the addresses with ;; TAGs. (let ((orig-table last-constant)) - (cl-loop for e across constvec - when (eq e last-constant) - do (setq last-constant (copy-hash-table e)) - and return nil) + (setq last-constant (copy-hash-table last-constant)) ;; Replace all addresses with TAGs. (maphash #'(lambda (value offset) (let ((match (assq offset tags))) -- cgit v1.2.3 From f8dbefbaa59bb17dd4a2dfa4d9ff560c46785792 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 16:08:01 -0500 Subject: Use `declare` instead of `def-edebug-spec` in most places * lisp/speedbar.el: Use lexical-binding. (speedbar-with-writable): Use `declare`. * lisp/subr.el (def-edebug-spec): Use `declare`. * lisp/cedet/ede/base.el: Use lexical-binding. (ede-with-projectfile): Use `declare`. (recentf-exclude): Declare var. * lisp/cedet/ede/pmake.el: Use lexical-binding. (ede-pmake-insert-variable-shared, ede-pmake-insert-variable-once): Use `declare`. * lisp/cedet/ede/proj-comp.el: Use lexical-binding. (ede-compiler-begin-unique, ede-compiler-only-once) (ede-linker-begin-unique, ede-linker-only-once): Use `declare`. * lisp/cedet/semantic/ctxt.el: Use lexical-binding. (semantic-with-buffer-narrowed-to-context) (semantic-with-buffer-narrowed-to-command): Use `declare`. (semantic--progress-reporter): Declare var. (semantic-ctxt-end-of-symbol-default): Remove unused var `fieldsep`. * lisp/cedet/semantic/lex-spp.el: Use lexical-binding. (define-lex-spp-macro-declaration-analyzer) (define-lex-spp-include-analyzer, semantic-lex-with-macro-used) (define-lex-spp-macro-undeclaration-analyzer): Use `declare`. (semantic-lex-spp-symbol-remove): Rename arg to avoid colliding with dynamic variable `obarray`. (semantic-lex-spp-symbol-pop): Remove unused var `oldvalue`. (semantic-lex-spp-lex-text-string): Remove unused var `analyzer`. * lisp/cedet/semantic/lex.el (define-lex) (semantic-lex-unterminated-syntax-protection, define-lex-analyzer) (define-lex-regex-analyzer, define-lex-block-analyzer) (semantic-lex-catch-errors): Use `declare`. * lisp/cedet/semantic/tag.el: Use lexical-binding. (semantic-with-buffer-narrowed-to-current-tag) (semantic-with-buffer-narrowed-to-tag): Use `declare`. * lisp/cedet/semantic/wisent.el: Use lexical-binding. (define-wisent-lexer): Use `declare`. * lisp/emacs-lisp/cl-lib.el (cl-pushnew): The arg to :test can be any form not just function form. * lisp/org/ob-comint.el (org-babel-comint-in-buffer) (org-babel-comint-with-output): Use `declare`. * lisp/org/ob-core.el (org-babel-map-src-blocks): Use `declare`. (org-babel-result-cond): Simplify edebug spec. * lisp/org/org-clock.el (org-with-clock-position, org-with-clock): * lisp/org/org-agenda.el (org-agenda-with-point-at-orig-entry): * lisp/org/ob-tangle.el (org-babel-with-temp-filebuffer): Use `declare`. * lisp/textmodes/rst.el (push): Remove redundant edebug spec. * lisp/vc/pcvs-parse.el: Use lexical-binding. (cvs-parse-buffer): Rename arg to avoid dynbound conflict. (cvs-or): Use `declare`. --- lisp/cedet/ede/base.el | 29 ++++++++-------------- lisp/cedet/ede/pmake.el | 22 ++++++++--------- lisp/cedet/ede/proj-comp.el | 35 ++++++++------------------- lisp/cedet/semantic/ctxt.el | 24 +++++++----------- lisp/cedet/semantic/lex-spp.el | 55 ++++++++++++------------------------------ lisp/cedet/semantic/lex.el | 38 ++++++----------------------- lisp/cedet/semantic/tag.el | 14 +++-------- lisp/cedet/semantic/wisent.el | 15 ++---------- lisp/emacs-lisp/cl-lib.el | 2 +- lisp/eshell/esh-var.el | 2 +- lisp/org/ob-comint.el | 6 ++--- lisp/org/ob-core.el | 17 ++++++------- lisp/org/ob-tangle.el | 3 +-- lisp/org/org-agenda.el | 2 +- lisp/org/org-clock.el | 6 ++--- lisp/org/org-pcomplete.el | 11 +++++---- lisp/pcmpl-gnu.el | 8 +++--- lisp/pcmpl-linux.el | 6 ++--- lisp/pcmpl-unix.el | 2 +- lisp/pcmpl-x.el | 3 ++- lisp/shell.el | 2 +- lisp/speedbar.el | 9 ++----- lisp/subr.el | 1 + lisp/textmodes/rst.el | 4 --- lisp/vc/pcvs-parse.el | 15 ++++++------ 25 files changed, 111 insertions(+), 220 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 810d6ef3bd4..3fcc023e0c6 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el @@ -1,4 +1,4 @@ -;;; ede/base.el --- Baseclasses for EDE. +;;; ede/base.el --- Baseclasses for EDE -*- lexical-binding: t; -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. @@ -288,7 +288,7 @@ All specific project types must derive from this project." ;; (defmacro ede-with-projectfile (obj &rest forms) "For the project in which OBJ resides, execute FORMS." - (declare (indent 1)) + (declare (indent 1) (debug t)) (unless (symbolp obj) (message "Beware! ede-with-projectfile's first arg is copied: %S" obj)) `(let* ((pf (if (obj-of-class-p ,obj 'ede-target) @@ -317,13 +317,15 @@ If set to nil, then the cache is not saved." (defvar ede-project-cache-files nil "List of project files EDE has seen before.") +(defvar recentf-exclude) + (defun ede-save-cache () "Save a cache of EDE objects that Emacs has seen before." (interactive) (when ede-project-placeholder-cache-file (let ((p ede-projects) (c ede-project-cache-files) - (recentf-exclude '( (lambda (f) t) )) + (recentf-exclude `( ,(lambda (_) t) )) ) (condition-case nil (progn @@ -461,7 +463,7 @@ Not all buffers need headers, so return nil if no applicable." (ede-buffer-header-file ede-object (current-buffer)) nil)) -(cl-defmethod ede-buffer-header-file ((this ede-project) buffer) +(cl-defmethod ede-buffer-header-file ((_this ede-project) _buffer) "Return nil, projects don't have header files." nil) @@ -487,12 +489,12 @@ Some projects may have multiple documentation files, so return a list." (ede-buffer-documentation-files ede-object (current-buffer)) nil)) -(cl-defmethod ede-buffer-documentation-files ((this ede-project) buffer) +(cl-defmethod ede-buffer-documentation-files ((this ede-project) _buffer) "Return all documentation in project THIS based on BUFFER." ;; Find the info node. (ede-documentation this)) -(cl-defmethod ede-buffer-documentation-files ((this ede-target) buffer) +(cl-defmethod ede-buffer-documentation-files ((_this ede-target) buffer) "Check for some documentation files for THIS. Also do a quick check to see if there is a Documentation tag in this BUFFER." (with-current-buffer buffer @@ -518,7 +520,7 @@ files in the project." proj (cdr proj))) found)) -(cl-defmethod ede-documentation ((this ede-target)) +(cl-defmethod ede-documentation ((_this ede-target)) "Return a list of files that provide documentation. Documentation is not for object THIS, but is provided by THIS for other files in the project." @@ -529,7 +531,7 @@ files in the project." (ede-html-documentation (ede-toplevel)) ) -(cl-defmethod ede-html-documentation ((this ede-project)) +(cl-defmethod ede-html-documentation ((_this ede-project)) "Return a list of HTML files provided by project THIS." ) @@ -636,18 +638,7 @@ PROJECT-FILE-NAME is a name of project file (short name, like `pom.xml', etc." (oset this directory (file-name-directory (oref this file)))) ) - - -;;; Hooks & Autoloads -;; -;; These let us watch various activities, and respond appropriately. - -;; (add-hook 'edebug-setup-hook -;; (lambda () -;; (def-edebug-spec ede-with-projectfile -;; (form def-body)))) - (provide 'ede/base) ;; Local variables: diff --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el index 4c948df4102..e1fe85659f8 100644 --- a/lisp/cedet/ede/pmake.el +++ b/lisp/cedet/ede/pmake.el @@ -1,4 +1,4 @@ -;;; ede-pmake.el --- EDE Generic Project Makefile code generator. +;;; ede-pmake.el --- EDE Generic Project Makefile code generator -*- lexical-binding: t; -*- ;; Copyright (C) 1998-2005, 2007-2021 Free Software Foundation, Inc. @@ -241,6 +241,7 @@ MFILENAME is the makefile to generate." (defmacro ede-pmake-insert-variable-shared (varname &rest body) "Add VARNAME into the current Makefile. Execute BODY in a location where a value can be placed." + (declare (debug t) (indent 1)) `(let ((addcr t) (v ,varname)) (if (save-excursion (goto-char (point-max)) @@ -258,11 +259,11 @@ Execute BODY in a location where a value can be placed." ,@body (if addcr (insert "\n")) (goto-char (point-max)))) -(put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1) (defmacro ede-pmake-insert-variable-once (varname &rest body) "Add VARNAME into the current Makefile if it doesn't exist. Execute BODY in a location where a value can be placed." + (declare (debug t) (indent 1)) `(let ((addcr t) (v ,varname)) (unless (save-excursion @@ -271,7 +272,6 @@ Execute BODY in a location where a value can be placed." ,@body (when addcr (insert "\n")) (goto-char (point-max))))) -(put 'ede-pmake-insert-variable-once 'lisp-indent-function 1) ;;; SOURCE VARIABLE NAME CONSTRUCTION @@ -289,7 +289,7 @@ Change . to _ in the variable name." ;;; DEPENDENCY FILE GENERATOR LISTS ;; -(cl-defmethod ede-proj-makefile-dependency-files ((this ede-proj-target)) +(cl-defmethod ede-proj-makefile-dependency-files ((_this ede-proj-target)) "Return a list of source files to convert to dependencies. Argument THIS is the target to get sources from." nil) @@ -302,7 +302,7 @@ Argument THIS is the target to get sources from." Use CONFIGURATION as the current configuration to query." (cdr (assoc configuration (oref this configuration-variables)))) -(cl-defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project)) +(cl-defmethod ede-proj-makefile-insert-variables-new ((_this ede-proj-project)) "Insert variables needed by target THIS. NOTE: Not yet in use! This is part of an SRecode conversion of @@ -420,7 +420,7 @@ Use CONFIGURATION as the current configuration to query." (cdr (assoc configuration (oref this configuration-variables)))) (cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile) - &optional moresource) + &optional _moresource) "Insert variables needed by target THIS. Optional argument MORESOURCE is a list of additional sources to add to the sources variable." @@ -449,12 +449,12 @@ sources variable." (ede-proj-makefile-insert-variables linker))))) (cl-defmethod ede-proj-makefile-insert-automake-pre-variables - ((this ede-proj-target)) + ((_this ede-proj-target)) "Insert variables needed by target THIS in Makefile.am before SOURCES." nil) (cl-defmethod ede-proj-makefile-insert-automake-post-variables - ((this ede-proj-target)) + ((_this ede-proj-target)) "Insert variables needed by target THIS in Makefile.am after SOURCES." nil) @@ -511,7 +511,7 @@ Argument THIS is the project that should insert stuff." (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets)) ) -(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target)) +(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((_this ede-proj-target)) "Insert any symbols that the DIST rule should depend on. Argument THIS is the target that should insert stuff." nil) @@ -530,7 +530,7 @@ Argument THIS is the target that should insert stuff." (insert " " (ede-subproject-relative-path sproj)) )))) -(cl-defmethod ede-proj-makefile-automake-insert-extradist ((this ede-proj-project)) +(cl-defmethod ede-proj-makefile-automake-insert-extradist ((_this ede-proj-project)) "Insert the EXTRADIST variable entries needed for Automake and EDE." (proj-comp-insert-variable-once "EXTRA_DIST" (insert "Project.ede"))) @@ -602,7 +602,7 @@ Argument THIS is the target that should insert stuff." "\t@false\n\n" "\n\n# End of Makefile\n"))) -(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-target)) +(cl-defmethod ede-proj-makefile-insert-rules ((_this ede-proj-target)) "Insert rules needed by THIS target." nil) diff --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el index 26aa66873a3..ba52784a7a8 100644 --- a/lisp/cedet/ede/proj-comp.el +++ b/lisp/cedet/ede/proj-comp.el @@ -1,4 +1,4 @@ -;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver +;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2001, 2004-2005, 2007, 2009-2021 Free Software ;; Foundation, Inc. @@ -172,12 +172,12 @@ Adds this rule to a .PHONY list.")) This is used when creating a Makefile to prevent duplicate variables and rules from being created.") -(cl-defmethod initialize-instance :after ((this ede-compiler) &rest fields) +(cl-defmethod initialize-instance :after ((this ede-compiler) &rest _fields) "Make sure that all ede compiler objects are cached in `ede-compiler-list'." (add-to-list 'ede-compiler-list this)) -(cl-defmethod initialize-instance :after ((this ede-linker) &rest fields) +(cl-defmethod initialize-instance :after ((this ede-linker) &rest _fields) "Make sure that all ede compiler objects are cached in `ede-linker-list'." (add-to-list 'ede-linker-list this)) @@ -185,11 +185,13 @@ rules from being created.") (defmacro ede-compiler-begin-unique (&rest body) "Execute BODY, making sure that `ede-current-build-list' is maintained. This will prevent rules from creating duplicate variables or rules." + (declare (indent 0) (debug t)) `(let ((ede-current-build-list nil)) ,@body)) (defmacro ede-compiler-only-once (object &rest body) "Using OBJECT, execute BODY only once per Makefile generation." + (declare (indent 1) (debug t)) `(if (not (member ,object ede-current-build-list)) (progn (add-to-list 'ede-current-build-list ,object) @@ -198,25 +200,18 @@ This will prevent rules from creating duplicate variables or rules." (defmacro ede-linker-begin-unique (&rest body) "Execute BODY, making sure that `ede-current-build-list' is maintained. This will prevent rules from creating duplicate variables or rules." + (declare (indent 0) (debug t)) `(let ((ede-current-build-list nil)) ,@body)) (defmacro ede-linker-only-once (object &rest body) "Using OBJECT, execute BODY only once per Makefile generation." + (declare (indent 1) (debug t)) `(if (not (member ,object ede-current-build-list)) (progn (add-to-list 'ede-current-build-list ,object) ,@body))) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec ede-compiler-begin-unique def-body) - (def-edebug-spec ede-compiler-only-once (form def-body)) - (def-edebug-spec ede-linker-begin-unique def-body) - (def-edebug-spec ede-linker-only-once (form def-body)) - (def-edebug-spec ede-pmake-insert-variable-shared (form def-body)) - )) - ;;; Queries (defun ede-proj-find-compiler (compilers sourcetype) "Return a compiler from the list COMPILERS that will compile SOURCETYPE." @@ -246,7 +241,7 @@ This will prevent rules from creating duplicate variables or rules." ) (oref this autoconf))) -(cl-defmethod ede-proj-flush-autoconf ((this ede-compilation-program)) +(cl-defmethod ede-proj-flush-autoconf ((_this ede-compilation-program)) "Flush the configure file (current buffer) to accommodate THIS." nil) @@ -281,8 +276,8 @@ If this compiler creates code that can be linked together, then the object files created by the compiler are considered intermediate." (oref this uselinker)) -(cl-defmethod ede-compiler-intermediate-object-variable ((this ede-compiler) - targetname) +(cl-defmethod ede-compiler-intermediate-object-variable ((_this ede-compiler) + targetname) "Return a string based on THIS representing a make object variable. TARGETNAME is the name of the target that these objects belong to." (concat targetname "_OBJ")) @@ -343,16 +338,6 @@ compiler it decides to use after inserting in the rule." commands)) (insert "\n"))) -;;; Some details about our new macro -;; -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec ede-compiler-begin-unique def-body))) -(put 'ede-compiler-begin-unique 'lisp-indent-function 0) -(put 'ede-compiler-only-once 'lisp-indent-function 1) -(put 'ede-linker-begin-unique 'lisp-indent-function 0) -(put 'ede-linker-only-once 'lisp-indent-function 1) - (provide 'ede/proj-comp) ;;; ede/proj-comp.el ends here diff --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el index 8d5b5dcdbdf..17ffaeff5e4 100644 --- a/lisp/cedet/semantic/ctxt.el +++ b/lisp/cedet/semantic/ctxt.el @@ -1,4 +1,4 @@ -;;; semantic/ctxt.el --- Context calculations for Semantic tools. +;;; semantic/ctxt.el --- Context calculations for Semantic tools -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2021 Free Software Foundation, Inc. @@ -137,18 +137,16 @@ Return non-nil if there is no upper context." (defmacro semantic-with-buffer-narrowed-to-context (&rest body) "Execute BODY with the buffer narrowed to the current context." + (declare (indent 0) (debug t)) `(save-restriction (semantic-narrow-to-context) ,@body)) -(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec semantic-with-buffer-narrowed-to-context - (def-body)))) ;;; Local Variables ;; -;; + +(defvar semantic--progress-reporter) + (define-overloadable-function semantic-get-local-variables (&optional point) "Get the local variables based on POINT's context. Local variables are returned in Semantic tag format. @@ -345,14 +343,10 @@ beginning and end of a command." (defmacro semantic-with-buffer-narrowed-to-command (&rest body) "Execute BODY with the buffer narrowed to the current command." + (declare (indent 0) (debug t)) `(save-restriction (semantic-narrow-to-command) ,@body)) -(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec semantic-with-buffer-narrowed-to-command - (def-body)))) (define-overloadable-function semantic-ctxt-end-of-symbol (&optional point) "Move point to the end of the current symbol under POINT. @@ -374,7 +368,7 @@ work on C like languages." ;; NOTE: The [ \n] expression below should used \\s-, but that ;; doesn't work in C since \n means end-of-comment, and isn't ;; really whitespace. - (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)")) + ;;(fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)")) (case-fold-search semantic-case-fold) (continuesearch t) (end nil) @@ -655,7 +649,7 @@ POINT defaults to the value of point in current buffer. You should override this function in multiple mode buffers to determine which major mode apply at point.") -(defun semantic-ctxt-current-mode-default (&optional point) +(defun semantic-ctxt-current-mode-default (&optional _point) "Return the major mode active at POINT. POINT defaults to the value of point in current buffer. This default implementation returns the current major mode." @@ -671,7 +665,7 @@ The return value can be a mixed list of either strings (names of types that are in scope) or actual tags (type declared locally that may or may not have a name.)") -(defun semantic-ctxt-scoped-types-default (&optional point) +(defun semantic-ctxt-scoped-types-default (&optional _point) "Return a list of scoped types by name for the current context at POINT. This is very different for various languages, and does nothing unless overridden." diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 408011c6286..5675b9f3e37 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -1,4 +1,4 @@ -;;; semantic/lex-spp.el --- Semantic Lexical Pre-processor +;;; semantic/lex-spp.el --- Semantic Lexical Pre-processor -*- lexical-binding: t; -*- ;; Copyright (C) 2006-2021 Free Software Foundation, Inc. @@ -106,22 +106,12 @@ added and removed from this symbol table.") Pushes NAME into the macro stack. The above stack is checked by `semantic-lex-spp-symbol' to not return true for any symbol currently being expanded." + (declare (indent 1) (debug (symbolp def-body))) `(unwind-protect (progn (push ,name semantic-lex-spp-expanded-macro-stack) ,@body) (pop semantic-lex-spp-expanded-macro-stack))) -(put 'semantic-lex-with-macro-used 'lisp-indent-function 1) - -(add-hook - 'edebug-setup-hook - #'(lambda () - - (def-edebug-spec semantic-lex-with-macro-used - (symbolp def-body) - ) - - )) ;;; MACRO TABLE UTILS ;; @@ -190,7 +180,7 @@ Disable debugging by entering nothing." (setq semantic-lex-spp-debug-symbol nil) (setq semantic-lex-spp-debug-symbol sym))) -(defmacro semantic-lex-spp-validate-value (name value) +(defmacro semantic-lex-spp-validate-value (_name _value) "Validate the NAME and VALUE of a macro before it is set." ; `(progn ; (when (not (semantic-lex-spp-value-valid-p ,value)) @@ -212,12 +202,11 @@ the dynamic map." (semantic-lex-spp-dynamic-map))) value)) -(defsubst semantic-lex-spp-symbol-remove (name &optional obarray) +(defsubst semantic-lex-spp-symbol-remove (name &optional map) "Remove the spp symbol with NAME. -If optional OBARRAY is non-nil, then use that obarray instead of +If optional obarray MAP is non-nil, then use that obarray instead of the dynamic map." - (unintern name (or obarray - (semantic-lex-spp-dynamic-map)))) + (unintern name (or map (semantic-lex-spp-dynamic-map)))) (defun semantic-lex-spp-symbol-push (name value) "Push macro NAME with VALUE into the map. @@ -246,7 +235,7 @@ Reverse with `semantic-lex-spp-symbol-pop'." (stack (semantic-lex-spp-dynamic-map-stack)) (mapsym (intern name map)) (stacksym (intern name stack)) - (oldvalue nil) + ;; (oldvalue nil) ) (if (or (not (boundp stacksym) ) (= (length (symbol-value stacksym)) 0)) @@ -324,7 +313,7 @@ For use with semanticdb restoration of state." ;; Default obarray for below is the dynamic map. (semantic-lex-spp-symbol-set (car e) (cdr e)))) -(defun semantic-lex-spp-reset-hook (start end) +(defun semantic-lex-spp-reset-hook (start _end) "Reset anything needed by SPP for parsing. In this case, reset the dynamic macro symbol table if START is (point-min). @@ -354,7 +343,7 @@ Return non-nil if it matches" (string-match regex value)) )) -(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end argvalues) +(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end _argvalues) "Convert lexical macro contents VAL into a macro expansion stream. These are for simple macro expansions that a user may have typed in directly. As such, we need to analyze the input text, to figure out what kind of real @@ -819,7 +808,7 @@ ARGVALUES are values for any arg list, or nil." ;; An analyzer that will push tokens from a macro in place ;; of the macro symbol. ;; -(defun semantic-lex-spp-analyzer-do-replace (sym val beg end) +(defun semantic-lex-spp-analyzer-do-replace (_sym val beg end) "Do the lexical replacement for SYM with VAL. Argument BEG and END specify the bounds of SYM in the buffer." (if (not val) @@ -1045,7 +1034,7 @@ and variable state from the current buffer." (fresh-toks nil) (toks nil) (origbuff (current-buffer)) - (analyzer semantic-lex-analyzer) + ;; (analyzer semantic-lex-analyzer) (important-vars '(semantic-lex-spp-macro-symbol-obarray semantic-lex-spp-project-macro-symbol-obarray semantic-lex-spp-dynamic-macro-symbol-obarray @@ -1176,6 +1165,7 @@ of type `spp-macro-def' is to be created. VALFORM are forms that return the value to be saved for this macro, or nil. When implementing a macro, you can use `semantic-lex-spp-stream-for-macro' to convert text into a lexical stream for storage in the macro." + (declare (debug (&define name stringp stringp form def-body))) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) @@ -1209,6 +1199,7 @@ REGEXP is a regular expression for the analyzer to match. See `define-lex-regex-analyzer' for more on regexp. TOKIDX is an index into REGEXP for which a new lexical token of type `spp-macro-undef' is to be created." + (declare (debug (&define name stringp stringp form))) (let ((start (make-symbol "start")) (end (make-symbol "end"))) `(define-lex-regex-analyzer ,name @@ -1244,7 +1235,7 @@ Note: Not implemented yet." :group 'semantic :type 'boolean) -(defun semantic-lex-spp-merge-header (name) +(defun semantic-lex-spp-merge-header (_name) "Extract and merge any macros from the header with NAME. Finds the header file belonging to NAME, gets the macros from that file, and then merge the macros with our current @@ -1269,6 +1260,7 @@ type of include. The return value should be of the form: (NAME . TYPE) where NAME is the name of the include, and TYPE is the type of the include, where a valid symbol is `system', or nil." + (declare (debug (&define name stringp stringp form def-body))) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) @@ -1369,23 +1361,6 @@ If BUFFER is not provided, use the current buffer." (princ "\n") )))) -;;; EDEBUG Handlers -;; -(add-hook - 'edebug-setup-hook - #'(lambda () - - (def-edebug-spec define-lex-spp-macro-declaration-analyzer - (&define name stringp stringp form def-body) - ) - - (def-edebug-spec define-lex-spp-macro-undeclaration-analyzer - (&define name stringp stringp form) - ) - - (def-edebug-spec define-lex-spp-include-analyzer - (&define name stringp stringp form def-body)))) - (provide 'semantic/lex-spp) ;; Local variables: diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index ae70d5c730a..b3399aa2e62 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -760,6 +760,7 @@ If two analyzers can match the same text, it is important to order the analyzers so that the one you want to match first occurs first. For example, it is good to put a number analyzer in front of a symbol analyzer which might mistake a number for a symbol." + (declare (debug (&define name stringp (&rest symbolp)))) `(defun ,name (start end &optional depth length) ,(concat doc "\nSee `semantic-lex' for more information.") ;; Make sure the state of block parsing starts over. @@ -1064,14 +1065,13 @@ the desired syntax, and a position returned. If `debug-on-error' is set, errors are not caught, so that you can debug them. Avoid using a large FORMS since it is duplicated." + (declare (indent 1) (debug t)) `(if (and debug-on-error semantic-lex-debug-analyzers) (progn ,@forms) (condition-case nil (progn ,@forms) (error (semantic-lex-unterminated-syntax-detected ,syntax))))) -(put 'semantic-lex-unterminated-syntax-protection - 'lisp-indent-function 1) (defmacro define-lex-analyzer (name doc condition &rest forms) "Create a single lexical analyzer NAME with DOC. @@ -1096,6 +1096,7 @@ Proper action in FORMS is to move the value of `semantic-lex-end-point' to after the location of the analyzed entry, and to add any discovered tokens at the beginning of `semantic-lex-token-stream'. This can be done by using `semantic-lex-push-token'." + (declare (debug (&define name stringp form def-body))) `(eval-and-compile (defvar ,name nil ,doc) (defun ,name nil) @@ -1122,6 +1123,7 @@ This can be done by using `semantic-lex-push-token'." "Create a lexical analyzer with NAME and DOC that will match REGEXP. FORMS are evaluated upon a successful match. See `define-lex-analyzer' for more about analyzers." + (declare (debug (&define name stringp form def-body))) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1139,6 +1141,8 @@ expression. FORMS are evaluated upon a successful match BEFORE the new token is created. It is valid to ignore FORMS. See `define-lex-analyzer' for more about analyzers." + (declare (debug + (&define name stringp form symbolp [ &optional form ] def-body))) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1163,6 +1167,7 @@ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM and CLOSE-DELIM are respectively the open and close delimiters identifying a block. OPEN-SYM and CLOSE-SYM are respectively the symbols returned in open and close tokens." + (declare (debug (&define name stringp form (&rest form)))) (let ((specs (cons spec1 specs)) spec open olist clist) (while specs @@ -1684,6 +1689,7 @@ the error will be caught here without the buffer's cache being thrown out of date. If there is an error, the syntax that failed is returned. If there is no error, then the last value of FORMS is returned." + (declare (indent 1) (debug (symbolp def-body))) (let ((ret (make-symbol "ret")) (syntax (make-symbol "syntax")) (start (make-symbol "start")) @@ -1707,35 +1713,7 @@ If there is no error, then the last value of FORMS is returned." ;;(message "Buffer not currently parsable (%S)." ,ret) (semantic-parse-tree-unparseable)) ,ret))) -(put 'semantic-lex-catch-errors 'lisp-indent-function 1) - -;;; Interfacing with edebug -;; -(add-hook - 'edebug-setup-hook - #'(lambda () - - (def-edebug-spec define-lex - (&define name stringp (&rest symbolp)) - ) - (def-edebug-spec define-lex-analyzer - (&define name stringp form def-body) - ) - (def-edebug-spec define-lex-regex-analyzer - (&define name stringp form def-body) - ) - (def-edebug-spec define-lex-simple-regex-analyzer - (&define name stringp form symbolp [ &optional form ] def-body) - ) - (def-edebug-spec define-lex-block-analyzer - (&define name stringp form (&rest form)) - ) - (def-edebug-spec semantic-lex-catch-errors - (symbolp def-body) - ) - - )) ;;; Compatibility with Semantic 1.x lexical analysis diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el index 85defe4f2c0..3d7bce8657a 100644 --- a/lisp/cedet/semantic/tag.el +++ b/lisp/cedet/semantic/tag.el @@ -1,4 +1,4 @@ -;;; semantic/tag.el --- tag creation and access +;;; semantic/tag.el --- Tag creation and access -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2005, 2007-2021 Free Software Foundation, Inc. @@ -1038,25 +1038,17 @@ See `semantic-tag-bounds'." (defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body) "Execute BODY with the buffer narrowed to the current tag." + (declare (indent 0) (debug t)) `(save-restriction (semantic-narrow-to-tag (semantic-current-tag)) ,@body)) -(put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag - (def-body)))) (defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body) "Narrow to TAG, and execute BODY." + (declare (indent 1) (debug t)) `(save-restriction (semantic-narrow-to-tag ,tag) ,@body)) -(put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1) -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec semantic-with-buffer-narrowed-to-tag - (def-body)))) ;;; Tag Hooks ;; diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index d5b73244a08..ecd96831352 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -1,4 +1,4 @@ -;;; semantic/wisent.el --- Wisent - Semantic gateway +;;; semantic/wisent.el --- Wisent - Semantic gateway -*- lexical-binding: t; -*- ;; Copyright (C) 2001-2007, 2009-2021 Free Software Foundation, Inc. @@ -69,6 +69,7 @@ Returned tokens must have the form: (TOKSYM VALUE START . END) where VALUE is the buffer substring between START and END positions." + (declare (debug (&define name stringp def-body))) `(defun ,name () ,doc (cond @@ -319,18 +320,6 @@ the standard function `semantic-parse-region'." (point-max)))))) ;; Return parse tree (nreverse ptree))) - -;;; Interfacing with edebug -;; -(add-hook - 'edebug-setup-hook - #'(lambda () - - (def-edebug-spec define-wisent-lexer - (&define name stringp def-body) - ) - - )) (provide 'semantic/wisent) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3bf3fd21ded..f06452ea174 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -140,7 +140,7 @@ to an element already in the list stored in PLACE. \n(fn X PLACE [KEYWORD VALUE]...)" (declare (debug (form place &rest - &or [[&or ":test" ":test-not" ":key"] function-form] + &or [[&or ":test" ":test-not" ":key"] form] [keywordp form]))) (if (symbolp place) (if (null keys) diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index a09c47ce7c2..9fccc6b1c9d 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -355,7 +355,7 @@ This function is explicit for adding to `eshell-parse-argument-hook'." (defun pcomplete/eshell-mode/setq () "Completion function for Eshell's `setq'." (while (and (pcomplete-here (all-completions pcomplete-stub - obarray 'boundp)) + obarray #'boundp)) (pcomplete-here)))) ;; FIXME the real "env" command does more than this, it runs a program diff --git a/lisp/org/ob-comint.el b/lisp/org/ob-comint.el index 18d4f3c9388..b14849df691 100644 --- a/lisp/org/ob-comint.el +++ b/lisp/org/ob-comint.el @@ -44,7 +44,7 @@ BUFFER is checked with `org-babel-comint-buffer-livep'. BODY is executed inside the protection of `save-excursion' and `save-match-data'." - (declare (indent 1)) + (declare (indent 1) (debug t)) `(progn (unless (org-babel-comint-buffer-livep ,buffer) (error "Buffer %s does not exist or has no process" ,buffer)) @@ -53,7 +53,6 @@ executed inside the protection of `save-excursion' and (save-excursion (let ((comint-input-filter (lambda (_input) nil))) ,@body)))))) -(def-edebug-spec org-babel-comint-in-buffer (form body)) (defmacro org-babel-comint-with-output (meta &rest body) "Evaluate BODY in BUFFER and return process output. @@ -67,7 +66,7 @@ elements are optional. This macro ensures that the filter is removed in case of an error or user `keyboard-quit' during execution of body." - (declare (indent 1)) + (declare (indent 1) (debug (sexp body))) (let ((buffer (nth 0 meta)) (eoe-indicator (nth 1 meta)) (remove-echo (nth 2 meta)) @@ -112,7 +111,6 @@ or user `keyboard-quit' during execution of body." string-buffer)) (setq string-buffer (substring string-buffer (match-end 0)))) (split-string string-buffer comint-prompt-regexp))))) -(def-edebug-spec org-babel-comint-with-output (sexp body)) (defun org-babel-comint-input-command (buffer cmd) "Pass CMD to BUFFER. diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 1343410792a..b1fd6943716 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -1100,7 +1100,7 @@ end-header-args -- point at the end of the header-args body ------------- string holding the body of the code block beg-body --------- point at the beginning of the body end-body --------- point at the end of the body" - (declare (indent 1)) + (declare (indent 1) (debug t)) (let ((tempvar (make-symbol "file"))) `(let* ((case-fold-search t) (,tempvar ,file) @@ -1139,7 +1139,6 @@ end-body --------- point at the end of the body" (goto-char end-block))))) (unless visited-p (kill-buffer to-be-removed)) (goto-char point)))) -(def-edebug-spec org-babel-map-src-blocks (form body)) ;;;###autoload (defmacro org-babel-map-inline-src-blocks (file &rest body) @@ -1354,7 +1353,7 @@ the `org-mode-hook'." (goto-char (match-beginning 0)) (org-babel-hide-hash) (goto-char (match-end 0)))))) -(add-hook 'org-mode-hook 'org-babel-hide-all-hashes) +(add-hook 'org-mode-hook #'org-babel-hide-all-hashes) (defun org-babel-hash-at-point (&optional point) "Return the value of the hash at POINT. @@ -1372,7 +1371,7 @@ This can be called with `\\[org-ctrl-c-ctrl-c]'." Add `org-babel-hide-result' as an invisibility spec for hiding portions of results lines." (add-to-invisibility-spec '(org-babel-hide-result . t))) -(add-hook 'org-mode-hook 'org-babel-result-hide-spec) +(add-hook 'org-mode-hook #'org-babel-result-hide-spec) (defvar org-babel-hide-result-overlays nil "Overlays hiding results.") @@ -1443,11 +1442,11 @@ portions of results lines." (push ov org-babel-hide-result-overlays))))) ;; org-tab-after-check-for-cycling-hook -(add-hook 'org-tab-first-hook 'org-babel-hide-result-toggle-maybe) +(add-hook 'org-tab-first-hook #'org-babel-hide-result-toggle-maybe) ;; Remove overlays when changing major mode (add-hook 'org-mode-hook (lambda () (add-hook 'change-major-mode-hook - 'org-babel-show-result-all 'append 'local))) + #'org-babel-show-result-all 'append 'local))) (defun org-babel-params-from-properties (&optional lang no-eval) "Retrieve source block parameters specified as properties. @@ -3075,8 +3074,7 @@ Emacs shutdown.")) (defmacro org-babel-result-cond (result-params scalar-form &rest table-forms) "Call the code to parse raw string results according to RESULT-PARAMS." - (declare (indent 1) - (debug (form form &rest form))) + (declare (indent 1) (debug t)) (org-with-gensyms (params) `(let ((,params ,result-params)) (unless (member "none" ,params) @@ -3093,7 +3091,6 @@ Emacs shutdown.")) (not (member "table" ,params)))) ,scalar-form ,@table-forms))))) -(def-edebug-spec org-babel-result-cond (form form body)) (defun org-babel-temp-file (prefix &optional suffix) "Create a temporary file in the `org-babel-temporary-directory'. @@ -3136,7 +3133,7 @@ of `org-babel-temporary-directory'." org-babel-temporary-directory "[directory not defined]")))))) -(add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory) +(add-hook 'kill-emacs-hook #'org-babel-remove-temporary-directory) (defun org-babel-one-header-arg-safe-p (pair safe-list) "Determine if the PAIR is a safe babel header arg according to SAFE-LIST. diff --git a/lisp/org/ob-tangle.el b/lisp/org/ob-tangle.el index 3c3943c8fa9..aa0373ab88e 100644 --- a/lisp/org/ob-tangle.el +++ b/lisp/org/ob-tangle.el @@ -150,7 +150,7 @@ represented in the file." "Open FILE into a temporary buffer execute BODY there like `progn', then kill the FILE buffer returning the result of evaluating BODY." - (declare (indent 1)) + (declare (indent 1) (debug t)) (let ((temp-path (make-symbol "temp-path")) (temp-result (make-symbol "temp-result")) (temp-file (make-symbol "temp-file")) @@ -164,7 +164,6 @@ evaluating BODY." (setf ,temp-result (progn ,@body))) (unless ,visited-p (kill-buffer ,temp-file)) ,temp-result))) -(def-edebug-spec org-babel-with-temp-filebuffer (form body)) ;;;###autoload (defun org-babel-tangle-file (file &optional target-file lang-re) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 99e5464c2b9..b9799d2abe8 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -2090,6 +2090,7 @@ Note that functions in this alist don't need to be quoted." If STRING is non-nil, the text property will be fetched from position 0 in that string. If STRING is nil, it will be fetched from the beginning of the current line." + (declare (debug t)) (org-with-gensyms (marker) `(let ((,marker (get-text-property (if ,string 0 (point-at-bol)) 'org-hd-marker ,string))) @@ -2097,7 +2098,6 @@ of the current line." (save-excursion (goto-char ,marker) ,@body))))) -(def-edebug-spec org-agenda-with-point-at-orig-entry (form body)) (defun org-add-agenda-custom-command (entry) "Replace or add a command in `org-agenda-custom-commands'. diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 2073b33380b..2844b0e511b 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -911,17 +911,17 @@ If CLOCK-SOUND is non-nil, it overrides `org-clock-sound'." (defmacro org-with-clock-position (clock &rest forms) "Evaluate FORMS with CLOCK as the current active clock." + (declare (indent 1) (debug t)) `(with-current-buffer (marker-buffer (car ,clock)) (org-with-wide-buffer (goto-char (car ,clock)) (beginning-of-line) ,@forms))) -(def-edebug-spec org-with-clock-position (form body)) -(put 'org-with-clock-position 'lisp-indent-function 1) (defmacro org-with-clock (clock &rest forms) "Evaluate FORMS with CLOCK as the current active clock. This macro also protects the current active clock from being altered." + (declare (indent 1) (debug t)) `(org-with-clock-position ,clock (let ((org-clock-start-time (cdr ,clock)) (org-clock-total-time) @@ -932,8 +932,6 @@ This macro also protects the current active clock from being altered." (org-back-to-heading t) (point-marker)))) ,@forms))) -(def-edebug-spec org-with-clock (form body)) -(put 'org-with-clock 'lisp-indent-function 1) (defsubst org-clock-clock-in (clock &optional resume start-time) "Clock in to the clock located by CLOCK. diff --git a/lisp/org/org-pcomplete.el b/lisp/org/org-pcomplete.el index 29d9d58482a..d8a4937b95a 100644 --- a/lisp/org/org-pcomplete.el +++ b/lisp/org/org-pcomplete.el @@ -239,11 +239,11 @@ When completing for #+STARTUP, for example, this function returns (require 'ox) (pcomplete-here (and org-export-exclude-tags - (list (mapconcat 'identity org-export-exclude-tags " "))))) + (list (mapconcat #'identity org-export-exclude-tags " "))))) (defun pcomplete/org-mode/file-option/filetags () "Complete arguments for the #+FILETAGS file option." - (pcomplete-here (and org-file-tags (mapconcat 'identity org-file-tags " ")))) + (pcomplete-here (and org-file-tags (mapconcat #'identity org-file-tags " ")))) (defun pcomplete/org-mode/file-option/language () "Complete arguments for the #+LANGUAGE file option." @@ -264,13 +264,13 @@ When completing for #+STARTUP, for example, this function returns (require 'ox) (pcomplete-here (and org-export-select-tags - (list (mapconcat 'identity org-export-select-tags " "))))) + (list (mapconcat #'identity org-export-select-tags " "))))) (defun pcomplete/org-mode/file-option/startup () "Complete arguments for the #+STARTUP file option." (while (pcomplete-here (let ((opts (pcomplete-uniquify-list - (mapcar 'car org-startup-options)))) + (mapcar #'car org-startup-options)))) ;; Some options are mutually exclusive, and shouldn't be completed ;; against if certain other options have already been seen. (dolist (arg pcomplete-args) @@ -340,7 +340,8 @@ When completing for #+STARTUP, for example, this function returns "Complete against TeX-style HTML entity names." (require 'org-entities) (while (pcomplete-here - (pcomplete-uniquify-list (remove nil (mapcar 'car-safe org-entities))) + (pcomplete-uniquify-list + (remove nil (mapcar #'car-safe org-entities))) (substring pcomplete-stub 1)))) (defun pcomplete/org-mode/todo () diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index dd964e36384..6c68645eb22 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -106,7 +106,7 @@ (while (pcomplete-here (completion-table-in-turn (pcmpl-gnu-make-rule-names) (pcomplete-entries)) - nil 'identity)))) + nil #'identity)))) (defun pcmpl-gnu-makefile-names () "Return a list of possible makefile names." @@ -336,7 +336,7 @@ Return the new list." (pcomplete-match-string 1 0))))) (unless saw-option (pcomplete-here - (mapcar 'char-to-string + (mapcar #'char-to-string (string-to-list "01234567ABCFGIKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz"))) (if (pcomplete-match "[xt]" 'first 1) @@ -355,7 +355,7 @@ Return the new list." (pcmpl-gnu-with-file-buffer file (mapcar #'tar-header-name tar-parse-info))))) (pcomplete-entries)) - nil 'identity)))) + nil #'identity)))) ;;;###autoload @@ -391,7 +391,7 @@ Return the new list." (string= prec "-execdir")) (while (pcomplete-here* (funcall pcomplete-command-completion-function) (pcomplete-arg 'last) t)))) - (while (pcomplete-here (pcomplete-dirs) nil 'identity)))) + (while (pcomplete-here (pcomplete-dirs) nil #'identity)))) ;;;###autoload (defalias 'pcomplete/gdb 'pcomplete/xargs) diff --git a/lisp/pcmpl-linux.el b/lisp/pcmpl-linux.el index 2f42dbd4fa1..263d646dc6e 100644 --- a/lisp/pcmpl-linux.el +++ b/lisp/pcmpl-linux.el @@ -50,20 +50,20 @@ (while (pcomplete-here (if (file-directory-p "/proc") (directory-files "/proc" nil "\\`[0-9]+\\'")) - nil 'identity))) + nil #'identity))) ;;;###autoload (defun pcomplete/umount () "Completion for GNU/Linux `umount'." (pcomplete-opt "hVafrnvt(pcmpl-linux-fs-types)") (while (pcomplete-here (pcmpl-linux-mounted-directories) - nil 'identity))) + nil #'identity))) ;;;###autoload (defun pcomplete/mount () "Completion for GNU/Linux `mount'." (pcomplete-opt "hVanfFrsvwt(pcmpl-linux-fs-types)o?L?U?") - (while (pcomplete-here (pcomplete-entries) nil 'identity))) + (while (pcomplete-here (pcomplete-entries) nil #'identity))) (defconst pcmpl-linux-fs-modules-path-format "/lib/modules/%s/kernel/fs/") diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el index 70273b94a1b..c1aaf829dcf 100644 --- a/lisp/pcmpl-unix.el +++ b/lisp/pcmpl-unix.el @@ -77,7 +77,7 @@ being via `pcmpl-ssh-known-hosts-file'." (let ((pcomplete-help "(fileutils)rm invocation")) (pcomplete-opt "dfirRv") (while (pcomplete-here (pcomplete-all-entries) nil - 'expand-file-name)))) + #'expand-file-name)))) ;;;###autoload (defun pcomplete/xargs () diff --git a/lisp/pcmpl-x.el b/lisp/pcmpl-x.el index 61d88666798..084f0e66bc8 100644 --- a/lisp/pcmpl-x.el +++ b/lisp/pcmpl-x.el @@ -301,7 +301,8 @@ long options." "nst" "ntd" "nto" "nvf" "obi" "obs" "ofp" "osh" "ovf" "par" "pch" "pck" "pia" "pin" "pow" "prc" "pre" "pro" "rch" "ret" "rng" "rpt" "rvl" "sig" "spa" "stl" "stu" "stv" "sus" "tai" - "tes" "thr" "ucp" "use" "voi" "zdi") (match-string 2 cur))) + "tes" "thr" "ucp" "use" "voi" "zdi") + (match-string 2 cur))) ((string-match "\\`-[LIn]\\([^;]+;\\)*\\([^;]*\\)\\'" cur) (pcomplete-here (pcomplete-dirs) (match-string 2 cur))) ((string-match "\\`-[Ee]\\(.*\\)\\'" cur) diff --git a/lisp/shell.el b/lisp/shell.el index 32128241655..9238ad1e8a0 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -463,7 +463,7 @@ Shell buffers. It implements `shell-completion-execonly' for (if (pcomplete-match "/") (pcomplete-here (pcomplete-entries nil (if shell-completion-execonly - 'file-executable-p))) + #'file-executable-p))) (pcomplete-here (nth 2 (shell--command-completion-data))))) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index e43978f4137..d64c72184ea 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -1,4 +1,4 @@ -;;; speedbar --- quick access to files and tags in a frame +;;; speedbar --- quick access to files and tags in a frame -*- lexical-binding: t; -*- ;; Copyright (C) 1996-2021 Free Software Foundation, Inc. @@ -1640,7 +1640,7 @@ variable `speedbar-obj-alist'." (defmacro speedbar-with-writable (&rest forms) "Allow the buffer to be writable and evaluate FORMS." - (declare (indent 0)) + (declare (indent 0) (debug t)) `(let ((inhibit-read-only t)) ,@forms)) @@ -4001,11 +4001,6 @@ TEXT is the buffer's name, TOKEN and INDENT are unused." "Speedbar face for separator labels in a display." :group 'speedbar-faces) -;; some edebug hooks -(add-hook 'edebug-setup-hook - (lambda () - (def-edebug-spec speedbar-with-writable def-body))) - ;; Fix a font lock problem for some versions of Emacs (and (boundp 'font-lock-global-modes) font-lock-global-modes diff --git a/lisp/subr.el b/lisp/subr.el index eb287287608..454ea54b6a4 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -88,6 +88,7 @@ Both SYMBOL and SPEC are unevaluated. The SPEC can be: a symbol (naming a function with an Edebug specification); or a list. The elements of the list describe the argument types; see Info node `(elisp)Specification List' for details." + (declare (indent 1)) `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) (defmacro lambda (&rest cdr) diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 2b31e7ed612..c51285d3de6 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -105,10 +105,6 @@ ;; Common Lisp stuff (require 'cl-lib) -;; Correct wrong declaration. -(def-edebug-spec push - (&or [form symbolp] [form gv-place])) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Support for `testcover' diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index 43816501bda..a95ea0d99da 100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@ -1,4 +1,4 @@ -;;; pcvs-parse.el --- the CVS output parser +;;; pcvs-parse.el --- the CVS output parser -*- lexical-binding: t; -*- ;; Copyright (C) 1991-2021 Free Software Foundation, Inc. @@ -73,12 +73,12 @@ by `$'." '("status" "add" "commit" "update" "remove" "checkout" "ci") "List of CVS commands whose output is understood by the parser.") -(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir) +(defun cvs-parse-buffer (parse-spec dcd &optional subdir) "Parse current buffer according to PARSE-SPEC. PARSE-SPEC is a function of no argument advancing the point and returning either a fileinfo or t (if the matched text should be ignored) or nil if it didn't match anything. -DONT-CHANGE-DISC just indicates whether the command was changing the disc +DCD just indicates whether the command was changing the disc or not (useful to tell the difference between `cvs-examine' and `cvs-update' output. The path names should be interpreted as relative to SUBDIR (defaults @@ -86,6 +86,7 @@ The path names should be interpreted as relative to SUBDIR (defaults Return a list of collected entries, or t if an error occurred." (goto-char (point-min)) (let ((fileinfos ()) + (dont-change-disc dcd) (cvs-current-dir "") (case-fold-search nil) (cvs-current-subdir (or subdir ""))) @@ -134,12 +135,12 @@ Match RE and if successful, execute MATCHES." (defmacro cvs-or (&rest alts) "Try each one of the ALTS alternatives until one matches." + (declare (debug t)) `(let ((-cvs-parse-point (point))) ,(cons 'or (mapcar (lambda (es) `(or ,es (ignore (goto-char -cvs-parse-point)))) alts)))) -(def-edebug-spec cvs-or t) ;; This is how parser tables should be executed (defun cvs-parse-run-table (parse-spec) @@ -190,9 +191,9 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." file (cvs-parse-msg) :subtype subtype keys)))) ;;;; CVS Process Parser Tables: -;;;; -;;;; The table for status and update could actually be merged since they -;;;; don't conflict. But they don't overlap much either. +;; +;; The table for status and update could actually be merged since they +;; don't conflict. But they don't overlap much either. (defun cvs-parse-table () "Table of message objects for `cvs-parse-process'." -- cgit v1.2.3 From c3163069a1e0a9aba16ae110ec75ace948e2ce0c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Fri, 12 Feb 2021 21:26:08 +0000 Subject: Fix ElDoc setup for eval-expression * lisp/emacs-lisp/eldoc.el (eldoc--eval-expression-setup): Don't set global value of eldoc-documentation-strategy (bug#44886). --- lisp/emacs-lisp/eldoc.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 90e075b1102..c95540ea3cf 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -248,7 +248,8 @@ expression point is on." :lighter eldoc-minor-mode-string #'elisp-eldoc-var-docstring nil t) (add-hook 'eldoc-documentation-functions #'elisp-eldoc-funcall nil t) - (setq eldoc-documentation-strategy 'eldoc-documentation-default))) + (setq-local eldoc-documentation-strategy + 'eldoc-documentation-default))) (eldoc-mode +1)) ;;;###autoload -- cgit v1.2.3 From d1be48fdedabb451d5c6cf315fd5f09a632e771f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 19:28:25 -0500 Subject: Edebug: Overload `edebug-form-spec` even less The `edebug-form-spec` symbol property was used both to map forms's head symbol to the corresponding spec, and to map spec element names to their expansion. This lead to name conflicts which break instrumentation of examples such as (cl-flet ((gate (x) x)) (gate 4)) because of the Edebug spec element `gate`. So introduce a new symbol property `edebug-elem-spec`. * lisp/subr.el (def-edebug-elem-spec): New function. * lisp/emacs-lisp/edebug.el (edebug--get-elem-spec): New function. (edebug-match-symbol): Use it. (Core Edebug elems): Put them on `edebug-elem-spec` instead of `edebug-form-spec`. (ELisp special forms): Set their `edebug-form-spec` via dolist. (Other non-core Edebug elems): Use `def-edebug-elem-spec`. (edebug-\`): Use `declare`. * lisp/emacs-lisp/pcase.el (pcase-PAT, pcase-FUN, pcase-QPAT): * lisp/skeleton.el (skeleton-edebug-spec): * lisp/emacs-lisp/cl-macs.el: Use `def-edebug-elem-spec`. * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests--conflicting-internal-names): New test. * test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el (edebug-test-code-cl-flet1): New test case. * doc/lispref/edebug.texi (Specification List): Add `def-edebug-elem-spec`. (Specification Examples): Use it. * doc/lispref/loading.texi (Hooks for Loading): Avoid the use of `def-edebug-spec` in example (better use `debug` declaration). --- doc/lispref/edebug.texi | 41 ++-- doc/lispref/loading.texi | 2 +- etc/NEWS | 7 + lisp/emacs-lisp/cl-macs.el | 170 ++++++++-------- lisp/emacs-lisp/edebug.el | 224 ++++++++++----------- lisp/emacs-lisp/pcase.el | 27 ++- lisp/skeleton.el | 8 +- lisp/subr.el | 17 +- .../edebug-resources/edebug-test-code.el | 10 + test/lisp/emacs-lisp/edebug-tests.el | 5 + 10 files changed, 273 insertions(+), 238 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 693d0e0630a..99d55c7ab95 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1203,7 +1203,7 @@ define Edebug specifications for special forms implemented in C. @defmac def-edebug-spec macro specification Specify which expressions of a call to macro @var{macro} are forms to be -evaluated. @var{specification} should be the edebug specification. +evaluated. @var{specification} should be the Edebug specification. Neither argument is evaluated. The @var{macro} argument can actually be any symbol, not just a macro @@ -1389,8 +1389,13 @@ indirect specification. If the symbol has an Edebug specification, this @dfn{indirect specification} should be either a list specification that is used in place of the symbol, or a function that is called to process the -arguments. The specification may be defined with @code{def-edebug-spec} -just as for macros. See the @code{defun} example. +arguments. The specification may be defined with +@code{def-edebug-elem-spec}: + +@defun def-edebug-elem-spec element specification +Define the @var{specification} to use in place of the symbol @var{element}. +@var{specification} has to be a list. +@end defun Otherwise, the symbol should be a predicate. The predicate is called with the argument, and if the predicate returns @code{nil}, the @@ -1568,14 +1573,14 @@ specification for @code{defmacro} is very similar to that for [&optional ("interactive" interactive)] def-body)) -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) +(def-edebug-elem-spec 'lambda-list + '(([&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ))) -(def-edebug-spec interactive - (&optional &or stringp def-form)) ; @r{Notice: @code{def-form}} +(def-edebug-elem-spec 'interactive + '(&optional &or stringp def-form)) ; @r{Notice: @code{def-form}} @end smallexample The specification for backquote below illustrates how to match @@ -1588,11 +1593,11 @@ could fail.) @smallexample (def-edebug-spec \` (backquote-form)) ; @r{Alias just for clarity.} -(def-edebug-spec backquote-form - (&or ([&or "," ",@@"] &or ("quote" backquote-form) form) - (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) +(def-edebug-elem-spec 'backquote-form + '(&or ([&or "," ",@@"] &or ("quote" backquote-form) form) + (backquote-form . [&or nil backquote-form]) + (vector &rest backquote-form) + sexp)) @end smallexample @@ -1635,10 +1640,10 @@ option. @xref{Instrumenting}. @defopt edebug-eval-macro-args When this is non-@code{nil}, all macro arguments will be instrumented -in the generated code. For any macro, an @code{edebug-form-spec} +in the generated code. For any macro, the @code{debug} declaration overrides this option. So to specify exceptions for macros that have -some arguments evaluated and some not, use @code{def-edebug-spec} to -specify an @code{edebug-form-spec}. +some arguments evaluated and some not, use the @code{debug} declaration +specify an Edebug form specification. @end defopt @defopt edebug-save-windows diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 22f0dde593a..33f37331947 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -1125,7 +1125,7 @@ You don't need to give a directory or extension in the file name @var{library}. Normally, you just give a bare file name, like this: @example -(with-eval-after-load "edebug" (def-edebug-spec c-point t)) +(with-eval-after-load "js" (define-key js-mode-map "\C-c\C-c" 'js-eval)) @end example To restrict which files can trigger the evaluation, include a diff --git a/etc/NEWS b/etc/NEWS index fe626fec7ec..464b955ee74 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -938,6 +938,13 @@ To customize obsolete user options, use 'customize-option' or --- *** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. ++++ +*** New function 'def-edebug-elem-spec' to define Edebug spec elements. +These used to be defined with 'def-edebug-spec' thus conflating the +two name spaces, which lead to name collisions. +The use of 'def-edebug-spec' to define Edebug spec elements is +declared obsolete. + *** Edebug specification lists can use some new keywords: +++ diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index c312afe55b9..5967e0d084f 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -186,14 +186,14 @@ The name is made by appending a number to PREFIX, default \"T\"." ;;; Program structure. -(def-edebug-spec cl-declarations - (&rest ("cl-declare" &rest sexp))) +(def-edebug-elem-spec 'cl-declarations + '(&rest ("cl-declare" &rest sexp))) -(def-edebug-spec cl-declarations-or-string - (&or lambda-doc cl-declarations)) +(def-edebug-elem-spec 'cl-declarations-or-string + '(&or lambda-doc cl-declarations)) -(def-edebug-spec cl-lambda-list - (([&rest cl-lambda-arg] +(def-edebug-elem-spec 'cl-lambda-list + '(([&rest cl-lambda-arg] [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] [&optional ["&rest" cl-lambda-arg]] [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] @@ -202,27 +202,27 @@ The name is made by appending a number to PREFIX, default \"T\"." &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) -(def-edebug-spec cl-&optional-arg - (&or (cl-lambda-arg &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&optional-arg + '(&or (cl-lambda-arg &optional def-form arg) arg)) -(def-edebug-spec cl-&key-arg - (&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) +(def-edebug-elem-spec 'cl-&key-arg + '(&or ([&or (symbolp cl-lambda-arg) arg] &optional def-form arg) arg)) -(def-edebug-spec cl-lambda-arg - (&or arg cl-lambda-list1)) +(def-edebug-elem-spec 'cl-lambda-arg + '(&or arg cl-lambda-list1)) -(def-edebug-spec cl-lambda-list1 - (([&optional ["&whole" arg]] ;; only allowed at lower levels - [&rest cl-lambda-arg] - [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] - [&optional ["&rest" cl-lambda-arg]] - [&optional ["&key" cl-&key-arg &rest cl-&key-arg - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-lambda-arg &optional def-form) arg]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-lambda-list1 + '(([&optional ["&whole" arg]] ;; only allowed at lower levels + [&rest cl-lambda-arg] + [&optional ["&optional" cl-&optional-arg &rest cl-&optional-arg]] + [&optional ["&rest" cl-lambda-arg]] + [&optional ["&key" cl-&key-arg &rest cl-&key-arg + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-lambda-arg &optional def-form) arg]] + . [&or arg nil]))) -(def-edebug-spec cl-type-spec sexp) +(def-edebug-elem-spec 'cl-type-spec '(sexp)) (defconst cl--lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux &whole &body &environment)) @@ -390,39 +390,39 @@ and BODY is implicitly surrounded by (cl-block NAME ...). ;; Note that &environment is only allowed as first or last items in the ;; top level list. -(def-edebug-spec cl-macro-list - (([&optional "&environment" arg] - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - [&optional "&environment" arg] - ))) - -(def-edebug-spec cl-macro-arg - (&or arg cl-macro-list1)) - -(def-edebug-spec cl-macro-list1 - (([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - . [&or arg nil]))) +(def-edebug-elem-spec 'cl-macro-list + '(([&optional "&environment" arg] + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + [&optional "&environment" arg] + ))) + +(def-edebug-elem-spec 'cl-macro-arg + '(&or arg cl-macro-list1)) + +(def-edebug-elem-spec 'cl-macro-list1 + '(([&optional "&whole" arg] ;; only allowed at lower levels + [&rest cl-macro-arg] + [&optional ["&optional" &rest + &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] + [&optional [[&or "&rest" "&body"] cl-macro-arg]] + [&optional ["&key" [&rest + [&or ([&or (symbolp cl-macro-arg) arg] + &optional def-form cl-macro-arg) + arg]] + &optional "&allow-other-keys"]] + [&optional ["&aux" &rest + &or (cl-macro-arg &optional def-form) arg]] + . [&or arg nil]))) ;;;###autoload (defmacro cl-defmacro (name args &rest body) @@ -452,19 +452,19 @@ more details. (indent 2)) `(defmacro ,name ,@(cl--transform-lambda (cons args body) name))) -(def-edebug-spec cl-lambda-expr - (&define ("lambda" cl-lambda-list - cl-declarations-or-string - [&optional ("interactive" interactive)] - def-body))) +(def-edebug-elem-spec 'cl-lambda-expr + '(&define ("lambda" cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body))) ;; Redefine function-form to also match cl-function -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) - ("cl-function" cl-function) - form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) + ("cl-function" cl-function) + form)) ;;;###autoload (defmacro cl-function (func) @@ -1051,20 +1051,20 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&rest loop-clause] ;; )) -;; (def-edebug-spec loop-with -;; ("with" loop-var +;; (def-edebug-elem-spec 'loop-with +;; '("with" loop-var ;; loop-type-spec ;; [&optional ["=" form]] ;; &rest ["and" loop-var ;; loop-type-spec ;; [&optional ["=" form]]])) -;; (def-edebug-spec loop-for-as -;; ([&or "for" "as"] loop-for-as-subclause +;; (def-edebug-elem-spec 'loop-for-as +;; '([&or "for" "as"] loop-for-as-subclause ;; &rest ["and" loop-for-as-subclause])) -;; (def-edebug-spec loop-for-as-subclause -;; (loop-var +;; (def-edebug-elem-spec 'loop-for-as-subclause +;; '(loop-var ;; loop-type-spec ;; &or ;; [[&or "in" "on" "in-ref" "across-ref"] @@ -1124,19 +1124,19 @@ For more details, see Info node `(cl)Loop Facility'. ;; [&optional ["by" form]] ;; ])) -;; (def-edebug-spec loop-initial-final -;; (&or ["initially" +;; (def-edebug-elem-spec 'loop-initial-final +;; '(&or ["initially" ;; ;; [&optional &or "do" "doing"] ;; CLtL2 doesn't allow this. ;; &rest loop-non-atomic-expr] ;; ["finally" &or ;; [[&optional &or "do" "doing"] &rest loop-non-atomic-expr] ;; ["return" form]])) -;; (def-edebug-spec loop-and-clause -;; (loop-clause &rest ["and" loop-clause])) +;; (def-edebug-elem-spec 'loop-and-clause +;; '(loop-clause &rest ["and" loop-clause])) -;; (def-edebug-spec loop-clause -;; (&or +;; (def-edebug-elem-spec 'loop-clause +;; '(&or ;; [[&or "while" "until" "always" "never" "thereis"] form] ;; [[&or "collect" "collecting" @@ -1163,10 +1163,10 @@ For more details, see Info node `(cl)Loop Facility'. ;; loop-initial-final ;; )) -;; (def-edebug-spec loop-non-atomic-expr -;; ([¬ atom] form)) +;; (def-edebug-elem-spec 'loop-non-atomic-expr +;; '([¬ atom] form)) -;; (def-edebug-spec loop-var +;; (def-edebug-elem-spec 'loop-var ;; ;; The symbolp must be last alternative to recognize e.g. (a b . c) ;; ;; loop-var => ;; ;; (loop-var . [&or nil loop-var]) @@ -1175,13 +1175,13 @@ For more details, see Info node `(cl)Loop Facility'. ;; ;; (symbolp . (symbolp . [&or nil loop-var])) ;; ;; (symbolp . (symbolp . loop-var)) ;; ;; (symbolp . (symbolp . symbolp)) == (symbolp symbolp . symbolp) -;; (&or (loop-var . [&or nil loop-var]) [gate symbolp])) +;; '(&or (loop-var . [&or nil loop-var]) [gate symbolp])) -;; (def-edebug-spec loop-type-spec -;; (&optional ["of-type" loop-d-type-spec])) +;; (def-edebug-elem-spec 'loop-type-spec +;; '(&optional ["of-type" loop-d-type-spec])) -;; (def-edebug-spec loop-d-type-spec -;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) +;; (def-edebug-elem-spec 'loop-d-type-spec +;; '(&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 782299454ea..47b45614e71 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -261,6 +261,14 @@ The argument is usually a symbol, but it doesn't have to be." (define-obsolete-function-alias 'get-edebug-spec #'edebug-get-spec "28.1") +(defun edebug--get-elem-spec (elem) + "Return the specs of the Edebug element ELEM, if any. +ELEM has to be a symbol." + (or (get elem 'edebug-elem-spec) + ;; For backward compatibility, we also allow the use of + ;; a form's name as a shorthand to refer to its spec. + (edebug-get-spec elem))) + ;;;###autoload (defun edebug-basic-spec (spec) "Return t if SPEC uses only extant spec symbols. @@ -1757,16 +1765,11 @@ contains a circular object." (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. )) - ;; FIXME: We abuse `edebug-form-spec' here. It's normally used to store the - ;; specs for a given sexp's head, but here we use it to keep the - ;; function implementing of a given "core spec". - (put (car pair) 'edebug-form-spec (cdr pair))) + (put (car pair) 'edebug-elem-spec (cdr pair))) (defun edebug-match-symbol (cursor symbol) ;; Match a symbol spec. - ;; FIXME: We abuse `edebug-get-spec' here, passing it a *spec* rather than - ;; the head element of a source sexp. - (let* ((spec (edebug-get-spec symbol))) + (let* ((spec (edebug--get-elem-spec symbol))) (cond (spec (if (consp spec) @@ -2184,112 +2187,114 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;;;* Emacs special forms and some functions. -;; quote expects only one argument, although it allows any number. -(def-edebug-spec quote sexp) - -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) - -(def-edebug-spec defun - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] - [&optional ("interactive" interactive)] - def-body)) -(def-edebug-spec defmacro - ;; FIXME: Improve `declare' so we can Edebug gv-expander and - ;; gv-setter declarations. - (&define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] def-body)) - -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. +(pcase-dolist + (`(,name ,spec) + + '((quote (sexp)) ;quote expects only one arg, tho it allows any number. + + ;; The standard defining forms. + (defvar (symbolp &optional form stringp)) + (defconst defvar) + + ;; Contrary to macros, special forms default to assuming that all args + ;; are normal forms, so we don't need to do anything about those + ;; special forms: + ;;(save-current-buffer t) + ;;(save-excursion t) + ;;... + ;;(progn t) + + ;; `defun' and `defmacro' are not special forms (any more), but it's + ;; more convenient to define their Edebug spec here. + (defun ( &define name lambda-list lambda-doc + [&optional ("declare" &rest sexp)] + [&optional ("interactive" &optional &or stringp def-form)] + def-body)) + + ;; FIXME: Improve `declare' so we can Edebug gv-expander and + ;; gv-setter declarations. + (defmacro ( &define name lambda-list lambda-doc + [&optional ("declare" &rest sexp)] + def-body)) + + ;; function expects a symbol or a lambda or macro expression + ;; A macro is allowed by Emacs. + (function (&or symbolp lambda-expr)) + + ;; FIXME? The manual uses this form (maybe that's just + ;; for illustration purposes?): + ;; (let ((&rest &or symbolp (gate symbolp &optional form)) body)) + (let ((&rest &or (symbolp &optional form) symbolp) body)) + (let* let) + + (setq (&rest symbolp form)) + (cond (&rest (&rest form))) + + (condition-case ( symbolp form + &rest ([&or symbolp (&rest symbolp)] body))) + + (\` (backquote-form)) + + ;; Assume immediate quote in unquotes mean backquote at next + ;; higher level. + (\, (&or ("quote" edebug-\`) def-form)) + (\,@ (&define ;; so (,@ form) is never wrapped. + &or ("quote" edebug-\`) def-form)) + )) + (put name 'edebug-form-spec spec)) -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) +(def-edebug-elem-spec 'lambda-list + '(([&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ))) -(def-edebug-spec lambda-doc - (&optional [&or stringp - (&define ":documentation" def-form)])) +(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list. -(def-edebug-spec interactive - (&optional &or stringp def-form)) +(def-edebug-elem-spec 'lambda-doc + '(&optional [&or stringp + (&define ":documentation" def-form)])) ;; A function-form is for an argument that may be a function or a form. ;; This specially recognizes anonymous functions quoted with quote. -(def-edebug-spec function-form +(def-edebug-elem-spec 'function-form ;Deprecated, use `form'! ;; form at the end could also handle "function", ;; but recognize it specially to avoid wrapping function forms. - (&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) - -;; function expects a symbol or a lambda or macro expression -;; A macro is allowed by Emacs. -(def-edebug-spec function (&or symbolp lambda-expr)) - -;; A macro expression is a lambda expression with "macro" prepended. -(def-edebug-spec macro (&define "lambda" lambda-list def-body)) - -;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro]))) - -;; Standard functions that take function-forms arguments. - -;; FIXME? The manual uses this form (maybe that's just for illustration?): -;; (def-edebug-spec let -;; ((&rest &or symbolp (gate symbolp &optional form)) -;; body)) -(def-edebug-spec let - ((&rest &or (symbolp &optional form) symbolp) - body)) - -(def-edebug-spec let* let) - -(def-edebug-spec setq (&rest symbolp form)) - -(def-edebug-spec cond (&rest (&rest form))) - -(def-edebug-spec condition-case - (symbolp - form - &rest ([&or symbolp (&rest symbolp)] body))) - - -(def-edebug-spec \` (backquote-form)) + '(&or ([&or "quote" "function"] &or symbolp lambda-expr) form)) ;; Supports quotes inside backquotes, ;; but only at the top level inside unquotes. -(def-edebug-spec backquote-form - (&or - ;; Disallow instrumentation of , and ,@ inside a nested backquote, since - ;; these are likely to be forms generated by a macro being debugged. - ("`" nested-backquote-form) - ([&or "," ",@"] &or ("quote" backquote-form) form) - ;; The simple version: - ;; (backquote-form &rest backquote-form) - ;; doesn't handle (a . ,b). The straightforward fix: - ;; (backquote-form . [&or nil backquote-form]) - ;; uses up too much stack space. - ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. - (backquote-form [&rest [¬ ","] backquote-form] - . [&or nil backquote-form]) - ;; If you use dotted forms in backquotes, replace the previous line - ;; with the following. This takes quite a bit more stack space, however. - ;; (backquote-form . [&or nil backquote-form]) - (vector &rest backquote-form) - sexp)) - -(def-edebug-spec nested-backquote-form - (&or - ("`" &error "Triply nested backquotes (without commas \"between\" them) \ +(def-edebug-elem-spec 'backquote-form + '(&or + ;; Disallow instrumentation of , and ,@ inside a nested backquote, since + ;; these are likely to be forms generated by a macro being debugged. + ("`" nested-backquote-form) + ([&or "," ",@"] &or ("quote" backquote-form) form) + ;; The simple version: + ;; (backquote-form &rest backquote-form) + ;; doesn't handle (a . ,b). The straightforward fix: + ;; (backquote-form . [&or nil backquote-form]) + ;; uses up too much stack space. + ;; Note that `(foo . ,@bar) is not valid, so we don't need to handle it. + (backquote-form [&rest [¬ ","] backquote-form] + . [&or nil backquote-form]) + ;; If you use dotted forms in backquotes, replace the previous line + ;; with the following. This takes quite a bit more stack space, however. + ;; (backquote-form . [&or nil backquote-form]) + (vector &rest backquote-form) + sexp)) + +(def-edebug-elem-spec 'nested-backquote-form + '(&or + ("`" &error "Triply nested backquotes (without commas \"between\" them) \ are too difficult to instrument") - ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or - ;; (\,@ ...) matched on the next line. - ([&or "," ",@"] backquote-form) - (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] - . [&or nil nested-backquote-form]) - (vector &rest nested-backquote-form) - sexp)) + ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or + ;; (\,@ ...) matched on the next line. + ([&or "," ",@"] backquote-form) + (nested-backquote-form [&rest [¬ "," ",@"] nested-backquote-form] + . [&or nil nested-backquote-form]) + (vector &rest nested-backquote-form) + sexp)) ;; Special version of backquote that instruments backquoted forms ;; destined to be evaluated, usually as the result of a @@ -2304,20 +2309,9 @@ are too difficult to instrument") ;; ,@ might have some problems. -(defalias 'edebug-\` '\`) ;; same macro as regular backquote. -(def-edebug-spec edebug-\` (def-form)) - -;; Assume immediate quote in unquotes mean backquote at next higher level. -(def-edebug-spec \, (&or ("quote" edebug-\`) def-form)) -(def-edebug-spec \,@ (&define ;; so (,@ form) is never wrapped. - &or ("quote" edebug-\`) def-form)) - -;; New byte compiler. - -(def-edebug-spec save-selected-window t) -(def-edebug-spec save-current-buffer t) - -;; Anything else? +(defmacro edebug-\` (exp) + (declare (debug (def-form))) + (list '\` exp)) ;;; The debugger itself diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index d6c96c1ec82..5d428ac846a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -62,15 +62,14 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) -(def-edebug-spec pcase-PAT - (&or (&lookup symbolp pcase--get-edebug-spec) - sexp)) +(def-edebug-elem-spec 'pcase-PAT + '(&or (&lookup symbolp pcase--get-edebug-spec) sexp)) -(def-edebug-spec pcase-FUN - (&or lambda-expr - ;; Punt on macros/special forms. - (functionp &rest form) - sexp)) +(def-edebug-elem-spec 'pcase-FUN + '(&or lambda-expr + ;; Punt on macros/special forms. + (functionp &rest form) + sexp)) ;; Only called from edebug. (declare-function edebug-get-spec "edebug" (symbol)) @@ -925,13 +924,13 @@ Otherwise, it defers to REST which is a list of branches of the form (t (error "Unknown pattern `%S'" upat))))) (t (error "Incorrect MATCH %S" (car matches))))) -(def-edebug-spec pcase-QPAT +(def-edebug-elem-spec 'pcase-QPAT ;; Cf. edebug spec for `backquote-form' in edebug.el. - (&or ("," pcase-PAT) - (pcase-QPAT [&rest [¬ ","] pcase-QPAT] - . [&or nil pcase-QPAT]) - (vector &rest pcase-QPAT) - sexp)) + '(&or ("," pcase-PAT) + (pcase-QPAT [&rest [¬ ","] pcase-QPAT] + . [&or nil pcase-QPAT]) + (vector &rest pcase-QPAT) + sexp)) (pcase-defmacro \` (qpat) "Backquote-style pcase patterns: \\=`QPAT diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 48491e43cae..8a50fbef643 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -104,10 +104,10 @@ are integer buffer positions in the reverse order of the insertion order.") (defvar skeleton-point) (defvar skeleton-regions) -(def-edebug-spec skeleton-edebug-spec - ([&or null stringp (stringp &rest stringp) [[¬ atom] sexp]] - &rest &or "n" "_" "-" ">" "@" "&" "!" "|" "resume:" - ("quote" def-form) skeleton-edebug-spec def-form)) +(def-edebug-elem-spec 'skeleton-edebug-spec + '([&or null stringp (stringp &rest stringp) [[¬ atom] sexp]] + &rest &or "n" "_" "-" ">" "@" "&" "!" "|" "resume:" + ("quote" def-form) skeleton-edebug-spec def-form)) ;;;###autoload (defmacro define-skeleton (command documentation &rest skeleton) "Define a user-configurable COMMAND that enters a statement skeleton. diff --git a/lisp/subr.el b/lisp/subr.el index 454ea54b6a4..70ee281fe6e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -82,7 +82,7 @@ Testcover will raise an error." form) (defmacro def-edebug-spec (symbol spec) - "Set the `edebug-form-spec' property of SYMBOL according to SPEC. + "Set the Edebug SPEC to use for sexps which have SYMBOL as head. Both SYMBOL and SPEC are unevaluated. The SPEC can be: 0 (instrument no arguments); t (instrument all arguments); a symbol (naming a function with an Edebug specification); or a list. @@ -91,6 +91,21 @@ Info node `(elisp)Specification List' for details." (declare (indent 1)) `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) +(defun def-edebug-elem-spec (name spec) + "Define a new Edebug spec element NAME as shorthand for SPEC. +The SPEC has to be a list or a symbol. +The elements of the list describe the argument types; see +Info node `(elisp)Specification List' for details. +If SPEC is a symbol it should name another pre-existing Edebug element." + (declare (indent 1)) + (when (string-match "\\`[&:]" (symbol-name name)) + ;; & and : have special meaning in spec element names. + (error "Edebug spec name cannot start with '&' or ':'")) + (unless (consp spec) + (error "Edebug spec has to be a list: %S" spec)) + (put name 'edebug-elem-spec spec)) + + (defmacro lambda (&rest cdr) "Return an anonymous function. Under dynamic binding, a call of the form (lambda ARGS DOCSTRING diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index f8ca39c8c6e..d77df3c3c51 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -137,5 +137,15 @@ ,(cons func args)))) (wrap + 1 x))) +(defun edebug-test-code-cl-flet1 () + (cl-flet + ;; This `&rest' sexp head should not collide with + ;; the Edebug spec elem of the same name. + ((f (&rest x) x) + (gate (x) (+ x 5))) + ;; This call to `gate' shouldn't collide with the Edebug spec elem + ;; of the same name. + (message "Hi %s" (gate 7)))) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 6a6080df3c8..c11bfcf0012 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -954,6 +954,11 @@ primary ones (Bug#42671)." (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) +(ert-deftest edebug-tests--conflicting-internal-names () + "Check conflicts between form's head symbols and Edebug spec elements." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "cl-flet1" '(10) t))) + (ert-deftest edebug-tests-cl-flet () "Check that Edebug can instrument `cl-flet' forms without name clashes (Bug#41853)." -- cgit v1.2.3 From ca0842347e5437bcaeeded4a7fd55e0e48ed4bad Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 12 Feb 2021 22:53:38 -0500 Subject: Edebug: Make it possible to debug `gv-expander`s in `declare` Arrange for declarations to be able to specify their own specs via the `edebug-declaration-spec` property. * lisp/emacs-lisp/edebug.el: (edebug--get-declare-spec): New function. (def-declarations): New spec element. (defun, defmacro): Use it in their spec. * lisp/emacs-lisp/gv.el (gv-expander, gv-setter): Set `edebug-declaration-spec`. * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests-gv-expander): New test. * test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el (edebug-test-code-use-gv-expander): New test case. --- lisp/emacs-lisp/edebug.el | 12 ++++++++---- lisp/emacs-lisp/gv.el | 5 +++++ test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el | 6 ++++++ test/lisp/emacs-lisp/edebug-tests.el | 11 +++++++++++ 4 files changed, 30 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 47b45614e71..394f47090ca 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2207,14 +2207,12 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;; `defun' and `defmacro' are not special forms (any more), but it's ;; more convenient to define their Edebug spec here. (defun ( &define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] + [&optional ("declare" def-declarations)] [&optional ("interactive" &optional &or stringp def-form)] def-body)) - ;; FIXME: Improve `declare' so we can Edebug gv-expander and - ;; gv-setter declarations. (defmacro ( &define name lambda-list lambda-doc - [&optional ("declare" &rest sexp)] + [&optional ("declare" def-declarations)] def-body)) ;; function expects a symbol or a lambda or macro expression @@ -2243,6 +2241,12 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." )) (put name 'edebug-form-spec spec)) +(defun edebug--get-declare-spec (head) + (get head 'edebug-declaration-spec)) + +(def-edebug-elem-spec 'def-declarations + '(&rest &or (&lookup symbolp edebug--get-declare-spec) sexp)) + (def-edebug-elem-spec 'lambda-list '(([&rest arg] [&optional ["&optional" arg &rest arg]] diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index c160aa1fd35..edacdf7f0c8 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -187,6 +187,11 @@ arguments as NAME. DO is a function as defined in `gv-get'." (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) +;;;###autoload +(let ((spec '(&or symbolp ("lambda" &define lambda-list def-body)))) + (put 'gv-expander 'edebug-declaration-spec spec) + (put 'gv-setter 'edebug-declaration-spec spec)) + ;; (defmacro gv-define-expand (name expander) ;; "Use EXPANDER to handle NAME as a generalized var. ;; NAME is a symbol: the name of a function, macro, or special form. diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index d77df3c3c51..835d3781d09 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -147,5 +147,11 @@ ;; of the same name. (message "Hi %s" (gate 7)))) +(defun edebug-test-code-use-gv-expander (x) + (declare (gv-expander + (lambda (do) + (funcall do `(car ,x) (lambda (v) `(setcar ,x ,v)))))) + (car x)) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index c11bfcf0012..dfe2cb32065 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -959,6 +959,17 @@ primary ones (Bug#42671)." (edebug-tests-with-normal-env (edebug-tests-setup-@ "cl-flet1" '(10) t))) +(ert-deftest edebug-tests-gv-expander () + "Edebug can instrument `gv-expander' expressions." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-gv-expander" nil t) + (should (equal + (catch 'text + (run-at-time 0 nil + (lambda () (throw 'text (buffer-substring (point) (+ (point) 5))))) + (eval '(setf (edebug-test-code-use-gv-expander (cons 'a 'b)) 3) t)) + "(func")))) + (ert-deftest edebug-tests-cl-flet () "Check that Edebug can instrument `cl-flet' forms without name clashes (Bug#41853)." -- cgit v1.2.3 From f65402f851c91523ca44450c609bee07d37b9036 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 13 Feb 2021 10:41:45 -0500 Subject: (backtrace-goto-source-functions): Make it a normal abnormal hook * lisp/emacs-lisp/backtrace.el (backtrace-goto-source-functions): Don't mark it as buffer-local any more. (backtrace-goto-source): Use `run-hook-with-args-until-success`. * lisp/emacs-lisp/edebug.el (edebug-pop-to-backtrace): Clarify that the hook is only intended to be modified buffer-locally. --- lisp/emacs-lisp/backtrace.el | 8 +++----- lisp/emacs-lisp/edebug.el | 3 ++- 2 files changed, 5 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 3e1c3292650..ea70baa9532 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -190,7 +190,7 @@ This is commonly used to recompute `backtrace-frames'.") (defvar-local backtrace-print-function #'cl-prin1 "Function used to print values in the current Backtrace buffer.") -(defvar-local backtrace-goto-source-functions nil +(defvar backtrace-goto-source-functions nil "Abnormal hook used to jump to the source code for the current frame. Each hook function is called with no argument, and should return non-nil if it is able to switch to the buffer containing the @@ -638,10 +638,8 @@ content of the sexp." (source-available (plist-get (backtrace-frame-flags frame) :source-available))) (unless (and source-available - (catch 'done - (dolist (func backtrace-goto-source-functions) - (when (funcall func) - (throw 'done t))))) + (run-hook-with-args-until-success + 'backtrace-goto-source-functions)) (user-error "Source code location not known")))) (defun backtrace-help-follow-symbol (&optional pos) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 394f47090ca..cbf2d171a96 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -4247,7 +4247,8 @@ This should be a list of `edebug---frame' objects.") (pop-to-buffer edebug-backtrace-buffer) (unless (derived-mode-p 'backtrace-mode) (backtrace-mode) - (add-hook 'backtrace-goto-source-functions #'edebug--backtrace-goto-source)) + (add-hook 'backtrace-goto-source-functions + #'edebug--backtrace-goto-source nil t)) (setq edebug-instrumented-backtrace-frames (backtrace-get-frames 'edebug-debugger :constructor #'edebug--make-frame) -- cgit v1.2.3 From 2007afd21b5f6c72a7a9c15fd7c4785331f2700f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 13 Feb 2021 16:21:53 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug--handle-&-spec-op <&name>): New method (edebug--concat-name): New function. (edebug-match-name, edebug-match-cl-generic-method-qualifier) (edebug-match-cl-generic-method-args): Delete functions. * doc/lispref/edebug.texi (Specification List): Document it. * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Use `&name`. (cl-generic--method-qualifier-p): New predicate. (cl-defmethod): Use it and `&name`. * lisp/emacs-lisp/cl-macs.el (cl-defun, cl-iter-defun, cl-flet): * lisp/emacs-lisp/eieio-compat.el (defmethod): * lisp/emacs-lisp/gv.el (gv-define-setter): * lisp/emacs-lisp/ert.el (ert-deftest): Use `&name`. * lisp/erc/erc-backend.el (define-erc-response-handler): Use `declare` and `&name`. --- doc/lispref/edebug.texi | 28 +++++-------- etc/NEWS | 9 ++-- lisp/emacs-lisp/cl-generic.el | 36 ++++++++++------ lisp/emacs-lisp/cl-macs.el | 9 ++-- lisp/emacs-lisp/edebug.el | 92 ++++++++++++++++++++++++----------------- lisp/emacs-lisp/eieio-compat.el | 2 +- lisp/emacs-lisp/ert.el | 4 +- lisp/emacs-lisp/gv.el | 3 +- lisp/erc/erc-backend.el | 12 +++--- 9 files changed, 111 insertions(+), 84 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 99d55c7ab95..2412e844b70 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1444,29 +1444,23 @@ Here is a list of additional specifications that may appear only after @code{&define}. See the @code{defun} example. @table @code +@item &name +Extracts the name of the current defining form from the code. +It takes the form @code{&name [@var{prestring}] @var{spec} +[@var{poststring}] @var{fun} @var{args...}} and means that Edebug will +match @var{spec} against the code and then call @var{fun} with the +concatenation of the current name, @var{args...}, @var{prestring}, +the code that matched @code{spec}, and @var{poststring}. If @var{fun} +is absent, it defaults to a function that concatenates the arguments +(with an @code{@} between the previous name and the new). + @item name The argument, a symbol, is the name of the defining form. +Shorthand for @code{[&name symbolp]}. A defining form is not required to have a name field; and it may have multiple name fields. -@item :name -This construct does not actually match an argument. The element -following @code{:name} should be a symbol; it is used as an additional -name component for the definition. You can use this to add a unique, -static component to the name of the definition. It may be used more -than once. - -@item :unique -This construct is like @code{:name}, but generates unique names. It -does not match an argument. The element following @code{:unique} -should be a string; it is used as the prefix for an additional name -component for the definition. You can use this to add a unique, -dynamic component to the name of the definition. This is useful for -macros that can define the same symbol multiple times in different -scopes, such as @code{cl-flet}; @ref{Function Bindings,,,cl}. It may -be used more than once. - @item arg The argument, a symbol, is the name of an argument of the defining form. However, lambda-list keywords (symbols starting with @samp{&}) diff --git a/etc/NEWS b/etc/NEWS index aead8c6f781..de26c0172b1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -936,7 +936,11 @@ To customize obsolete user options, use 'customize-option' or ** Edebug --- -*** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. +*** Obsoletions +**** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. + ++++ +**** The Edebug spec operator ':name NAME' is obsolete. +++ *** New function 'def-edebug-elem-spec' to define Edebug spec elements. @@ -954,8 +958,7 @@ declared obsolete. **** '&error MSG' unconditionally aborts the current edebug instrumentation. +++ -**** ':unique STRING' appends STRING to the Edebug name of the current -definition to (hopefully) make it more unique. +**** '&name SPEC FUN' extracts the current name from the code matching SPEC. ** ElDoc diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8e36dbe4a36..229608395eb 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -206,22 +206,29 @@ DEFAULT-BODY, if present, is used as the body of a default method. \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3) (debug - (&define [&or name ("setf" name :name setf)] listp - lambda-doc + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. + listp lambda-doc [&rest [&or ("declare" &rest sexp) (":argument-precedence-order" &rest sexp) (&define ":method" - ;; FIXME: The `:unique' + ;; FIXME: The `gensym' ;; construct works around ;; Bug#42672. We'd rather want ;; names like those generated by ;; `cl-defmethod', but that ;; requires larger changes to ;; Edebug. - :unique "cl-generic-:method@" - [&rest cl-generic-method-qualifier] - cl-generic-method-args lambda-doc + [&name "cl-generic-:method@" []] + [&name [] gensym] ;Make it unique! + [&name + [[&rest cl-generic--method-qualifier-p] + ;; FIXME: We don't actually want the + ;; argument's names to be considered + ;; part of the name of the defined + ;; function. + listp]] ;Formal args + lambda-doc def-body)]] def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) @@ -398,6 +405,9 @@ the specializer used will be the one returned by BODY." (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) +(defun cl-generic--method-qualifier-p (x) + (not (listp x))) + ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. @@ -440,15 +450,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (declare (doc-string 3) (indent defun) (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] - ;; ^^ This is the methods symbol - [ &rest cl-generic-method-qualifier ] - ;; Multiple qualifiers are allowed. - cl-generic-method-args ; arguments + [&name [sexp ;Allow (setf ...) additionally to symbols. + ;; Multiple qualifiers are allowed. + [&rest cl-generic--method-qualifier-p] + ;; FIXME: We don't actually want the argument's names + ;; to be considered part of the name of the + ;; defined function. + listp]] ; arguments lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) - (while (not (listp args)) + (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) (when (eq 'setf (car-safe name)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5967e0d084f..e2faf6df534 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -358,7 +358,7 @@ more details. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -376,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as iter-defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -2016,8 +2016,9 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name :unique "cl-flet@" form) - (&define name :unique "cl-flet@" + (debug ((&rest [&or (symbolp form) + (&define [&name symbolp "@cl-flet@"] + [&name [] gensym] ;Make it unique! cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index cbf2d171a96..867161e0280 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1748,16 +1748,12 @@ contains a circular object." (dolist (pair '((form . edebug-match-form) (sexp . edebug-match-sexp) (body . edebug-match-body) - (name . edebug-match-name) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) - (cl-generic-method-qualifier - . edebug-match-cl-generic-method-qualifier) - (cl-generic-method-args . edebug-match-cl-generic-method-args) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) (cl-macrolet-body . edebug-match-cl-macrolet-body) @@ -2056,19 +2052,61 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." ))) -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) +(cl-defmethod edebug--handle-&-spec-op ((_ (eql &name)) cursor specs) + "Compute the name for `&name SPEC FUN` spec operator. + +The full syntax of that operator is: + &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS... + +Extracts the head of the data by matching it against SPEC, +and then get the new name to use by calling + (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING]) +FUN should return either a string or a symbol. +FUN can be missing in which case it defaults to concatenating +the new name to the end of the old with an \"@\" char between the two. +PRESTRING and POSTSTRING are optional strings that get prepended +or appended to the actual name." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (prestrings (when (stringp spec) + (prog1 (list spec) (setq spec fun fun (pop args))))) + (poststrings (when (stringp fun) + (prog1 (list fun) (setq fun (pop args))))) + (exps (edebug-cursor-expressions cursor)) + (instrumented (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (newname (apply (or fun #'edebug--concat-name) + `(,@args ,edebug-def-name + ,@prestrings + ,@(seq-subseq exps 0 consumed) + ,@poststrings)))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (setq edebug-def-name (if (stringp newname) (intern newname) newname)) + instrumented)) + +(defun edebug--concat-name (oldname &rest newnames) + (let ((newname (if (null (cdr newnames)) + (car newnames) + ;; Put spaces between each name, but not for the + ;; leading and trailing strings, if any. + (let (beg mid end) + (dolist (name newnames) + (if (stringp name) + (push name (if mid end beg)) + (when end (setq mid (nconc end mid) end nil)) + (push name mid))) + (apply #'concat `(,@(nreverse beg) + ,(mapconcat (lambda (x) (format "%s" x)) + (nreverse mid) " ") + ,@(nreverse end))))))) + (if (null oldname) + (if (or (stringp newname) (symbolp newname)) + newname + (format "%s" newname)) + (format "%s@%s" edebug-def-name newname)))) + +(def-edebug-elem-spec 'name '(&name symbolp)) (cl-defgeneric edebug--handle-:-spec-op (op cursor spec) "Handle :foo spec operators. @@ -2094,26 +2132,6 @@ SPEC is the symbol name prefix for `gensym'." suffix))) nil) -(defun edebug-match-cl-generic-method-qualifier (cursor) - "Match a QUALIFIER for `cl-defmethod' at CURSOR." - (let ((args (edebug-top-element-required cursor "Expected qualifier"))) - ;; Like in CLOS spec, we support any non-list values. - (unless (atom args) (edebug-no-match cursor "Atom expected")) - ;; Append the arguments to `edebug-def-name' (Bug#42671). - (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - -(defun edebug-match-cl-generic-method-args (cursor) - (let ((args (edebug-top-element-required cursor "Expected arguments"))) - (if (not (consp args)) - (edebug-no-match cursor "List expected")) - ;; Append the arguments to edebug-def-name. - (setq edebug-def-name - (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - (defvar edebug--cl-macrolet-defs nil "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") (defvar edebug--current-cl-macrolet-defs nil diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index db97d4ca4e8..6d84839c341 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -105,7 +105,7 @@ Summary: (declare (doc-string 3) (obsolete cl-defmethod "25.1") (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] + [&name sexp] ;Allow (setf ...) additionally to symbols. ;; ^^ This is the methods symbol [ &optional symbolp ] ; this is key :before etc cl-generic-method-args ; arguments diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fdbf95319ff..e08fa7ac7b3 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -196,8 +196,8 @@ it has to be wrapped in `(eval (quote ...))'. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" - (declare (debug (&define :name test - name sexp [&optional stringp] + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index edacdf7f0c8..3200b1c3494 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -229,7 +229,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) + (declare (indent 2) + (debug (&define [&name symbolp "@gv-setter"] sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 6f1193cbb2b..73c2b56b02e 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -1079,14 +1079,12 @@ Finds hooks by looking in the `erc-server-responses' hash table." (erc-display-message parsed 'notice proc line))) -(put 'define-erc-response-handler 'edebug-form-spec - '(&define :name erc-response-handler - (name &rest name) - &optional sexp sexp def-body)) - (cl-defmacro define-erc-response-handler ((name &rest aliases) - &optional extra-fn-doc extra-var-doc - &rest fn-body) + &optional extra-fn-doc extra-var-doc + &rest fn-body) + (declare (debug (&define [&name "erc-response-handler@" + (symbolp &rest symbolp)] + &optional sexp sexp def-body))) "Define an ERC handler hook/function pair. NAME is the response name as sent by the server (see the IRC RFC for meanings). -- cgit v1.2.3 From 39a401ddae154b94e4c0e9c8ced1b27d9dc56daa Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 13 Feb 2021 17:50:31 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug-match-lambda-expr): Delete function (lambda-expr): Define with `def-edebug-elem-spec` instead. (edebug--handle-&-spec-op): Remove left over code. (interactive): Re-add mistakenly removed spec elem. * doc/lispref/edebug.texi (Specification List): Remove `function-form`. --- doc/lispref/edebug.texi | 10 +--------- etc/NEWS | 4 +++- lisp/emacs-lisp/edebug.el | 36 ++++++++---------------------------- 3 files changed, 12 insertions(+), 38 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 2412e844b70..46f5cb9026a 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1290,14 +1290,6 @@ Short for @code{&rest form}. See @code{&rest} below. If your macro wraps its body of code with @code{lambda} before it is evaluated, use @code{def-body} instead. See @code{def-body} below. -@item function-form -A function form: either a quoted function symbol, a quoted lambda -expression, or a form (that should evaluate to a function symbol or -lambda expression). This is useful when an argument that's a lambda -expression might be quoted with @code{quote} rather than -@code{function}, since it instruments the body of the lambda expression -either way. - @item lambda-expr A lambda expression with no quoting. @@ -1452,7 +1444,7 @@ match @var{spec} against the code and then call @var{fun} with the concatenation of the current name, @var{args...}, @var{prestring}, the code that matched @code{spec}, and @var{poststring}. If @var{fun} is absent, it defaults to a function that concatenates the arguments -(with an @code{@} between the previous name and the new). +(with an @code{@@} between the previous name and the new). @item name The argument, a symbol, is the name of the defining form. diff --git a/etc/NEWS b/etc/NEWS index de26c0172b1..d865aa7c746 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -940,7 +940,9 @@ To customize obsolete user options, use 'customize-option' or **** 'get-edebug-spec' is obsolete, replaced by 'edebug-get-spec'. +++ -**** The Edebug spec operator ':name NAME' is obsolete. +**** The spec operator ':name NAME' is obsolete, use '&name' instead. ++++ +**** The spec element 'function-form' is obsolete, use 'form' instead. +++ *** New function 'def-edebug-elem-spec' to define Edebug spec elements. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 867161e0280..1cc95f7ac8c 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1753,7 +1753,6 @@ contains a circular object." (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) - (lambda-expr . edebug-match-lambda-expr) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) (cl-macrolet-body . edebug-match-cl-macrolet-body) @@ -1873,7 +1872,7 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) - (instrumented-head (edebug-match-one-spec cursor (or spec 'sexp))) + (instrumented-head (edebug-match-one-spec cursor spec)) (consumed (- (length exps) (length (edebug-cursor-expressions cursor)))) (newspecs (apply fun (append args (seq-subseq exps 0 consumed))))) @@ -2026,32 +2025,6 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." offsets) specs)) -(defun edebug-match-lambda-expr (cursor) - ;; The expression must be a function. - ;; This will match any list form that begins with a symbol - ;; that has an edebug-form-spec beginning with &define. In - ;; practice, only lambda expressions should be used. - ;; I could add a &lambda specification to avoid confusion. - (let* ((sexp (edebug-top-element-required - cursor "Expected lambda expression")) - (offset (edebug-top-offset cursor)) - (head (and (consp sexp) (car sexp))) - (spec (and (symbolp head) (edebug-get-spec head))) - (edebug-inside-func nil)) - ;; Find out if this is a defining form from first symbol. - (if (and (consp spec) (eq '&define (car spec))) - (prog1 - (list - (edebug-defining-form - (edebug-new-cursor sexp offset) - (car offset);; before the sexp - (edebug-after-offset cursor) - (cons (symbol-name head) (cdr spec)))) - (edebug-move-cursor cursor)) - (edebug-no-match cursor "Expected lambda expression") - ))) - - (cl-defmethod edebug--handle-&-spec-op ((_ (eql &name)) cursor specs) "Compute the name for `&name SPEC FUN` spec operator. @@ -2271,12 +2244,19 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." &optional ["&rest" arg] ))) +(def-edebug-elem-spec 'lambda-expr + '(("lambda" &define lambda-list lambda-doc + [&optional ("interactive" interactive)] + def-body))) + (def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list. (def-edebug-elem-spec 'lambda-doc '(&optional [&or stringp (&define ":documentation" def-form)])) +(def-edebug-elem-spec 'interactive '(&optional &or stringp def-form)) + ;; A function-form is for an argument that may be a function or a form. ;; This specially recognizes anonymous functions quoted with quote. (def-edebug-elem-spec 'function-form ;Deprecated, use `form'! -- cgit v1.2.3 From 2d9ff601ab5fc7187f0466f22c6c5e9451bce04f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 13 Feb 2021 19:22:17 -0500 Subject: * lisp/emacs-lisp/edebug.el: Fix `called-interactively-p` And get rid of the old special-case handling of `interactive-p`, which is now redundant. (edebug--called-interactively-skip): Fix lexical-binding case, and adjust to some formerly missed call patterns. (edebug-def-interactive, edebug-interactive-p): Remove vars. (edebug-interactive-p-name, edebug-wrap-def-body) (edebug-make-enter-wrapper): Remove functions. (edebug-list-form): Don't special-case `interactive-p`. --- lisp/emacs-lisp/edebug.el | 70 ++++++++--------------------------------------- 1 file changed, 12 insertions(+), 58 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1cc95f7ac8c..76fb19023a0 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1235,54 +1235,11 @@ purpose by adding an entry to this alist, and setting (funcall edebug-after-instrumentation-function result)))) (defvar edebug-def-args) ; args of defining form. -(defvar edebug-def-interactive) ; is it an emacs interactive function? (defvar edebug-inside-func) ;; whether code is inside function context. ;; Currently def-form sets this to nil; def-body sets it to t. (defvar edebug--cl-macrolet-defs) ;; Fully defined below. -(defun edebug-interactive-p-name () - ;; Return a unique symbol for the variable used to store the - ;; status of interactive-p for this function. - (intern (format "edebug-%s-interactive-p" edebug-def-name))) - - -(defun edebug-wrap-def-body (forms) - "Wrap the FORMS of a definition body." - (if edebug-def-interactive - `(let ((,(edebug-interactive-p-name) - (called-interactively-p 'interactive))) - ,(edebug-make-enter-wrapper forms)) - (edebug-make-enter-wrapper forms))) - - -(defun edebug-make-enter-wrapper (forms) - ;; Generate the enter wrapper for some forms of a definition. - ;; This is not to be used for the body of other forms, e.g. `while', - ;; since it wraps the list of forms with a call to `edebug-enter'. - ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. - ;; Do this after parsing since that may find a name. - (when (string-match-p (rx bos "edebug-anon" (+ digit) eos) - (symbol-name edebug-old-def-name)) - ;; FIXME: Due to Bug#42701, we reset an anonymous name so that - ;; backtracking doesn't generate duplicate definitions. It would - ;; be better to not define wrappers in the case of a non-matching - ;; specification branch to begin with. - (setq edebug-old-def-name nil)) - (setq edebug-def-name - (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) - `(edebug-enter - (quote ,edebug-def-name) - ,(if edebug-inside-func - `(list - ;; Doesn't work with more than one def-body!! - ;; But the list will just be reversed. - ,@(nreverse edebug-def-args)) - 'nil) - (function (lambda () ,@forms)) - )) - - (defvar edebug-form-begin-marker) ; the mark for def being instrumented (defvar edebug-offset-index) ; the next available offset index. @@ -1404,7 +1361,6 @@ contains a circular object." (edebug-old-def-name (edebug--form-data-name form-data-entry)) edebug-def-name edebug-def-args - edebug-def-interactive edebug-inside-func;; whether wrapped code executes inside a function. ) @@ -1610,11 +1566,6 @@ contains a circular object." ((symbolp head) (cond ((null head) nil) ; () is valid. - ((eq head 'interactive-p) - ;; Special case: replace (interactive-p) with variable - (setq edebug-def-interactive 'check-it) - (edebug-move-cursor cursor) - (edebug-interactive-p-name)) (t (cons head (edebug-list-form-args head (edebug-move-cursor cursor)))))) @@ -2170,7 +2121,7 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." ;; This happens to handle bug#20281, tho maybe a better fix would be to ;; improve the `defun' spec. (when forms - (list (edebug-wrap-def-body forms))))) + (list (edebug-make-enter-wrapper forms))))) ;;;; Edebug Form Specs @@ -2922,7 +2873,6 @@ See `edebug-behavior-alist' for implementations.") (defvar edebug-outside-match-data) ; match data outside of edebug (defvar edebug-backtrace-buffer) ; each recursive edit gets its own (defvar edebug-inside-windows) -(defvar edebug-interactive-p) (defvar edebug-mode-map) ; will be defined fully later. @@ -2938,7 +2888,6 @@ See `edebug-behavior-alist' for implementations.") ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions)) (edebug-recursion-depth (recursion-depth)) edebug-entered ; bind locally to nil - (edebug-interactive-p nil) ; again non-interactive edebug-backtrace-buffer ; each recursive edit gets its own ;; The window configuration may be saved and restored ;; during a recursive-edit @@ -4588,13 +4537,18 @@ With prefix argument, make it a temporary breakpoint." (add-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) (defun edebug--called-interactively-skip (i frame1 frame2) - (when (and (eq (car-safe (nth 1 frame1)) 'lambda) - (eq (nth 1 (nth 1 frame1)) '()) - (eq (nth 1 frame2) 'edebug-enter)) + (when (and (memq (car-safe (nth 1 frame1)) '(lambda closure)) + ;; Lambda value with no arguments. + (null (nth (if (eq (car-safe (nth 1 frame1)) 'lambda) 1 2) + (nth 1 frame1))) + (memq (nth 1 frame2) '(edebug-enter edebug-default-enter))) ;; `edebug-enter' calls itself on its first invocation. - (if (eq (nth 1 (backtrace-frame i 'called-interactively-p)) - 'edebug-enter) - 2 1))) + (let ((s 1)) + (while (memq (nth 1 (backtrace-frame i 'called-interactively-p)) + '(edebug-enter edebug-default-enter)) + (cl-incf s) + (cl-incf i)) + s))) ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. -- cgit v1.2.3 From 103039b06c2c9a917fc796d2a4afda8433e37473 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 13 Feb 2021 19:24:33 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug-make-enter-wrapper): Reinstate. Removed by accident. --- lisp/emacs-lisp/edebug.el | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 76fb19023a0..8fadeba6c9a 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1240,6 +1240,33 @@ purpose by adding an entry to this alist, and setting (defvar edebug--cl-macrolet-defs) ;; Fully defined below. +(defun edebug-make-enter-wrapper (forms) + ;; Generate the enter wrapper for some forms of a definition. + ;; This is not to be used for the body of other forms, e.g. `while', + ;; since it wraps the list of forms with a call to `edebug-enter'. + ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. + ;; Do this after parsing since that may find a name. + (when (string-match-p (rx bos "edebug-anon" (+ digit) eos) + (symbol-name edebug-old-def-name)) + ;; FIXME: Due to Bug#42701, we reset an anonymous name so that + ;; backtracking doesn't generate duplicate definitions. It would + ;; be better to not define wrappers in the case of a non-matching + ;; specification branch to begin with. + (setq edebug-old-def-name nil)) + (setq edebug-def-name + (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) + `(edebug-enter + (quote ,edebug-def-name) + ,(if edebug-inside-func + `(list + ;; Doesn't work with more than one def-body!! + ;; But the list will just be reversed. + ,@(nreverse edebug-def-args)) + 'nil) + (function (lambda () ,@forms)) + )) + + (defvar edebug-form-begin-marker) ; the mark for def being instrumented (defvar edebug-offset-index) ; the next available offset index. -- cgit v1.2.3 From 760910f4917ad8ff5e1cd1bf0bfec443b02f0e44 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 12:37:44 +0100 Subject: Add a new buffer-local variable `minor-modes' * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Keep `minor-modes' updated. * src/buffer.c (bset_minor_modes, Fmake_indirect_buffer) (reset_buffer, init_buffer_once): Initialise `minor-modes'. (syms_of_buffer): Add `minor-modes' as a new permanently-local variable. * src/buffer.h (struct buffer): Add minor_modes_. --- doc/lispref/modes.texi | 5 +++++ etc/NEWS | 5 +++++ lisp/emacs-lisp/easy-mmode.el | 4 ++++ src/buffer.c | 13 +++++++++++++ src/buffer.h | 3 +++ 5 files changed, 30 insertions(+) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 3c64e97b3b9..3a4828c8fab 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1454,6 +1454,11 @@ used only with Diff mode. other minor modes in effect. It should be possible to activate and deactivate minor modes in any order. +@defvar minor-modes +This buffer-local variable lists the currently enabled minor modes in +the current buffer, and is a list if symbols. +@end defvar + @defvar minor-mode-list The value of this variable is a list of all minor mode commands. @end defvar diff --git a/etc/NEWS b/etc/NEWS index d865aa7c746..7e224b411f8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2266,6 +2266,11 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', * Lisp Changes in Emacs 28.1 ++++ +** New buffer-local variable 'minor-modes'. +This permanently buffer-local variable holds a list of currently +enabled minor modes in the current buffer (as a list of symbols). + ** The 'values' variable is now obsolete. --- diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 2916ae4adea..bfffbe4bf20 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -317,6 +317,10 @@ or call the function `%s'.")))) nil) (t t))) + ;; Keep `minor-modes' up to date. + (setq minor-modes (delq ',modefun minor-modes)) + (when ,getter + (push ',modefun minor-modes)) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) diff --git a/src/buffer.c b/src/buffer.c index 80c799e719b..487599dbbed 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -292,6 +292,11 @@ bset_major_mode (struct buffer *b, Lisp_Object val) b->major_mode_ = val; } static void +bset_minor_modes (struct buffer *b, Lisp_Object val) +{ + b->minor_modes_ = val; +} +static void bset_mark (struct buffer *b, Lisp_Object val) { b->mark_ = val; @@ -893,6 +898,7 @@ CLONE nil means the indirect buffer's state is reset to default values. */) bset_file_truename (b, Qnil); bset_display_count (b, make_fixnum (0)); bset_backed_up (b, Qnil); + bset_minor_modes (b, Qnil); bset_auto_save_file_name (b, Qnil); set_buffer_internal_1 (b); Fset (intern ("buffer-save-without-query"), Qnil); @@ -967,6 +973,7 @@ reset_buffer (register struct buffer *b) b->clip_changed = 0; b->prevent_redisplay_optimizations_p = 1; bset_backed_up (b, Qnil); + bset_minor_modes (b, Qnil); BUF_AUTOSAVE_MODIFF (b) = 0; b->auto_save_failure_time = 0; bset_auto_save_file_name (b, Qnil); @@ -5151,6 +5158,7 @@ init_buffer_once (void) bset_auto_save_file_name (&buffer_local_flags, make_fixnum (-1)); bset_read_only (&buffer_local_flags, make_fixnum (-1)); bset_major_mode (&buffer_local_flags, make_fixnum (-1)); + bset_minor_modes (&buffer_local_flags, make_fixnum (-1)); bset_mode_name (&buffer_local_flags, make_fixnum (-1)); bset_undo_list (&buffer_local_flags, make_fixnum (-1)); bset_mark_active (&buffer_local_flags, make_fixnum (-1)); @@ -5617,6 +5625,11 @@ The default value (normally `fundamental-mode') affects new buffers. A value of nil means to use the current buffer's major mode, provided it is not marked as "special". */); + DEFVAR_PER_BUFFER ("minor-modes", &BVAR (current_buffer, minor_modes), + Qnil, + doc: /* Minor modes currently active in the current buffer. +This is a list of symbols, or nil if there are no minor modes active. */); + DEFVAR_PER_BUFFER ("mode-name", &BVAR (current_buffer, mode_name), Qnil, doc: /* Pretty name of current buffer's major mode. diff --git a/src/buffer.h b/src/buffer.h index 790291f1185..0668d16608b 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -338,6 +338,9 @@ struct buffer /* Symbol naming major mode (e.g., lisp-mode). */ Lisp_Object major_mode_; + /* Symbol listing all currently enabled minor modes. */ + Lisp_Object minor_modes_; + /* Pretty name of major mode (e.g., "Lisp"). */ Lisp_Object mode_name_; -- cgit v1.2.3 From 43ecde85786ccbf4c07d535f08fd74c82a0af31b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 12:50:19 +0100 Subject: Introduce an :interactive keyword for `defined-derived-mode' * doc/lispref/modes.texi (Derived Modes): Document it. * lisp/emacs-lisp/derived.el (define-derived-mode): Introduce a new :interactive keyword. --- doc/lispref/modes.texi | 7 +++++++ etc/NEWS | 6 ++++++ lisp/emacs-lisp/derived.el | 7 ++++++- 3 files changed, 19 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 3a4828c8fab..7b8ab4cb4dd 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -861,6 +861,13 @@ abbrev table as @var{parent}, or @code{fundamental-mode-abbrev-table} if @var{parent} is @code{nil}. (Again, a @code{nil} value is @emph{not} equivalent to not specifying this keyword.) +@item :interactive +Modes are interactive commands by default. If you specify a +@code{nil} value, the mode defined here won't be interactive. This is +useful for modes that are never meant to be activated by users +manually, but are only supposed to be used in some specially-formatted +buffer. + @item :group If this is specified, the value should be the customization group for this mode. (Not all major modes have one.) The command diff --git a/etc/NEWS b/etc/NEWS index 7e224b411f8..08e1e94d83d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2271,6 +2271,12 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', This permanently buffer-local variable holds a list of currently enabled minor modes in the current buffer (as a list of symbols). ++++ +** 'defined-derived-mode' now takes an :interactive argument. +This can be used to control whether the defined mode is a command +or not, and is useful when defining commands that aren't meant to be +used by users directly. + ** The 'values' variable is now obsolete. --- diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 54528b2fb91..43d6dfd3c81 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -141,6 +141,9 @@ KEYWORD-ARGS: :after-hook FORM A single lisp form which is evaluated after the mode hooks have been run. It should not be quoted. + :interactive BOOLEAN + Whether the derived mode should be `interactive' or not. + The default is t. BODY: forms to execute just before running the hooks for the new mode. Do not use `interactive' here. @@ -194,6 +197,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare-syntax t) (hook (derived-mode-hook-name child)) (group nil) + (interactive t) (after-hook nil)) ;; Process the keyword args. @@ -203,6 +207,7 @@ See Info node `(elisp)Derived Modes' for more details. (:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil)) (:syntax-table (setq syntax (pop body)) (setq declare-syntax nil)) (:after-hook (setq after-hook (pop body))) + (:interactive (setq interactive (pop body))) (_ (pop body)))) (setq docstring (derived-mode-make-docstring @@ -246,7 +251,7 @@ No problems result if this variable is not bound. (defun ,child () ,docstring - (interactive) + ,(and interactive '(interactive)) ; Run the parent. (delay-mode-hooks -- cgit v1.2.3 From 58e0c8ee86e2c36245f1c5a1483f1c73600b4914 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:21:24 +0100 Subject: Extend the syntax of `interactive' to list applicable modes * doc/lispref/commands.texi (Using Interactive): Document the extended `interactive' form. * doc/lispref/loading.texi (Autoload): Document list-of-modes form. * lisp/emacs-lisp/autoload.el (make-autoload): Pick the list of modes from `interactive' out of the functions. * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Allow for the extended `interactive' form. * src/callint.c (Finteractive): Document the extended form. * src/data.c (Finteractive_form): Return the interactive form in the old format (even when there's an extended `interactive') to avoid having other parts of Emacs be aware of this. (Fcommand_modes): New defun. * src/emacs-module.c (GCALIGNED_STRUCT): Allow for modules to return command modes. * src/lisp.h: New function module_function_command_modes. --- doc/lispref/commands.texi | 19 +++++++++- doc/lispref/loading.texi | 3 ++ etc/NEWS | 8 ++++ lisp/emacs-lisp/autoload.el | 15 ++++++-- lisp/emacs-lisp/bytecomp.el | 40 ++++++++++++-------- src/callint.c | 9 ++++- src/data.c | 92 ++++++++++++++++++++++++++++++++++++++++++--- src/emacs-module.c | 8 +++- src/eval.c | 9 ++++- src/lisp.h | 3 ++ src/lread.c | 1 + 11 files changed, 179 insertions(+), 28 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 3a2c7d019ef..d60745a825b 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -156,7 +156,7 @@ commands by adding the @code{interactive} form to them. makes a Lisp function an interactively-callable command, and how to examine a command's @code{interactive} form. -@defspec interactive arg-descriptor +@defspec interactive &optional arg-descriptor &rest modes This special form declares that a function is a command, and that it may therefore be called interactively (via @kbd{M-x} or by entering a key sequence bound to it). The argument @var{arg-descriptor} declares @@ -177,6 +177,23 @@ forms are executed; at this time, if the @code{interactive} form occurs within the body, the form simply returns @code{nil} without even evaluating its argument. +The @var{modes} list allows specifying which modes the command is +meant to be used in. This affects, for instance, completion in +@kbd{M-x} (commands won't be offered as completions if they don't +match (using @code{derived-mode-p}) the current major mode, or if the +mode is a minor mode, whether it's switched on in the current buffer). +This will also make @kbd{C-h m} list these commands (if they aren't +bound to any keys). + +For instance: + +@lisp +(interactive "p" dired-mode) +@end lisp + +This will mark the command as applicable for modes derived from +@code{dired-mode} only. + By convention, you should put the @code{interactive} form in the function body, as the first top-level form. If there is an @code{interactive} form in both the @code{interactive-form} symbol diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 33f37331947..8c6aeb04721 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -510,6 +510,9 @@ specification is not given here; it's not needed unless the user actually calls @var{function}, and when that happens, it's time to load the real definition. +If @var{interactive} is a list, it is interpreted as a list of modes +this command is applicable for. + You can autoload macros and keymaps as well as ordinary functions. Specify @var{type} as @code{macro} if @var{function} is really a macro. Specify @var{type} as @code{keymap} if @var{function} is really a diff --git a/etc/NEWS b/etc/NEWS index 08e1e94d83d..d8f0bc60726 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2266,6 +2266,14 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', * Lisp Changes in Emacs 28.1 ++++ +** The 'interactive' syntax has been extended to allow listing applicable modes. +Forms like '(interactive "p" dired-mode)' can be used to annotate the +commands as being applicable for modes derived from 'dired-mode', +or if the mode is a minor mode, that the current buffer has that +minor mode activated. Note that using this form will create byte code +that is not compatible with byte code in previous Emacs versions. + +++ ** New buffer-local variable 'minor-modes'. This permanently buffer-local variable holds a list of currently diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index ec7492dd4b1..ae17039645a 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently." ((stringp (car-safe rest)) (car rest)))) ;; Look for an interactive spec. (interactive (pcase body - ((or `((interactive . ,_) . ,_) - `(,_ (interactive . ,_) . ,_)) - t)))) + ((or `((interactive . ,iargs) . ,_) + `(,_ (interactive . ,iargs) . ,_)) + ;; List of modes or just t. + (if (nthcdr 1 iargs) + (list 'quote (nthcdr 1 iargs)) + t))))) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (consp args) (setq doc (help-add-fundoc-usage doc args))) @@ -207,7 +210,11 @@ expression, in which case we want to handle forms differently." easy-mmode-define-minor-mode define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) ,(if macrop ''macro nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 89068a14f02..5c6b9c2e39a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2939,7 +2939,8 @@ for symbols generated by the byte compiler itself." ;; unless it is the last element of the body. (if (cdr body) (setq body (cdr body)))))) - (int (assq 'interactive body))) + (int (assq 'interactive body)) + command-modes) (when lexical-binding (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) @@ -2951,9 +2952,10 @@ for symbols generated by the byte compiler itself." (if (eq int (car body)) (setq body (cdr body))) (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) + (unless (seq-every-p #'symbolp (cdr (cdr int))) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) + (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, @@ -2964,14 +2966,15 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - nil - (setq int `(interactive ,newform))))) + (setq int + (if (and (eq (car-safe form) 'list) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + (not lexical-binding)) + `(interactive ,form) + `(interactive ,newform))))) ((cdr int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) @@ -3002,9 +3005,16 @@ for symbols generated by the byte compiler itself." (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + ;; optionally, the interactive spec (and the modes the + ;; command applies to). + (cond + ;; We have some command modes, so use the vector form. + (command-modes + (list (vector (nth 1 int) command-modes))) + ;; No command modes, use the simple form with just the + ;; interactive spec. + (int + (list (nth 1 int))))))))) (defvar byte-compile-reserved-constants 0) diff --git a/src/callint.c b/src/callint.c index d3f49bc35d1..18624637843 100644 --- a/src/callint.c +++ b/src/callint.c @@ -104,7 +104,14 @@ If the string begins with `^' and `shift-select-mode' is non-nil, Emacs first calls the function `handle-shift-selection'. You may use `@', `*', and `^' together. They are processed in the order that they appear, before reading any arguments. -usage: (interactive &optional ARG-DESCRIPTOR) */ + +If MODES is present, it should be a list of mode names (symbols) that +this command is applicable for. The main effect of this is that +`M-x TAB' (by default) won't list this command if the current buffer's +mode doesn't match the list. That is, if either the major mode isn't +derived from them, or (when it's a minor mode) the mode isn't in effect. + +usage: (interactive &optional ARG-DESCRIPTOR &rest MODES) */ attributes: const) (Lisp_Object args) { diff --git a/src/data.c b/src/data.c index 38cde0ff8b2..7bddc039f6f 100644 --- a/src/data.c +++ b/src/data.c @@ -904,7 +904,17 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (COMPILEDP (fun)) { if (PVSIZE (fun) > COMPILED_INTERACTIVE) - return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); + { + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + if (VECTORP (form)) + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, AREF (form, 0)); + else + /* Old form -- just the interactive spec. */ + return list2 (Qinteractive, form); + } } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -920,10 +930,80 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); - else if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (XCDR (fun))); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + Lisp_Object spec = Fassq (Qinteractive, form); + if (NILP (Fcdr (Fcdr (spec)))) + return spec; + else + return list2 (Qinteractive, Fcar (Fcdr (spec))); + } + } + return Qnil; +} + +DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, + doc: /* Return the modes COMMAND is defined for. +If COMMAND is not a command, the return value is nil. +The value, if non-nil, is a list of mode name symbols. */) + (Lisp_Object command) +{ + Lisp_Object fun = indirect_function (command); /* Check cycles. */ + + if (NILP (fun)) + return Qnil; + + fun = command; + while (SYMBOLP (fun)) + fun = Fsymbol_function (fun); + + if (SUBRP (fun)) + { + if (!NILP (XSUBR (fun)->command_modes)) + return XSUBR (fun)->command_modes; + } + else if (COMPILEDP (fun)) + { + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + if (VECTORP (form)) + /* New form -- the second element is the command modes. */ + return AREF (form, 1); + else + /* Old .elc file -- no command modes. */ + return Qnil; + } +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + { + Lisp_Object form + = module_function_command_modes (XMODULE_FUNCTION (fun)); + if (! NILP (form)) + return form; + } +#endif + else if (AUTOLOADP (fun)) + { + Lisp_Object modes = Fnth (make_int (3), fun); + if (CONSP (modes)) + return modes; + else + return Qnil; + } + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + return Fcdr (Fcdr (Fassq (Qinteractive, form))); + } } return Qnil; } @@ -3908,6 +3988,7 @@ syms_of_data (void) defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); + defsubr (&Scommand_modes); defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); @@ -4030,6 +4111,7 @@ This variable cannot be set; trying to do so will signal an error. */); DEFSYM (Qunlet, "unlet"); DEFSYM (Qset, "set"); DEFSYM (Qset_default, "set-default"); + DEFSYM (Qcommand_modes, "command-modes"); defsubr (&Sadd_variable_watcher); defsubr (&Sremove_variable_watcher); defsubr (&Sget_variable_watchers); diff --git a/src/emacs-module.c b/src/emacs-module.c index 894dffcf21e..f8fb54c0728 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -549,7 +549,7 @@ struct Lisp_Module_Function union vectorlike_header header; /* Fields traced by GC; these must come first. */ - Lisp_Object documentation, interactive_form; + Lisp_Object documentation, interactive_form, command_modes; /* Fields ignored by GC. */ ptrdiff_t min_arity, max_arity; @@ -646,6 +646,12 @@ module_function_interactive_form (const struct Lisp_Module_Function *fun) return fun->interactive_form; } +Lisp_Object +module_function_command_modes (const struct Lisp_Module_Function *fun) +{ + return fun->command_modes; +} + static emacs_value module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs, emacs_value *args) diff --git a/src/eval.c b/src/eval.c index 91fc4e68377..542d7f686e6 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2080,14 +2080,21 @@ then strings and vectors are not accepted. */) DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0, doc: /* Define FUNCTION to autoload from FILE. FUNCTION is a symbol; FILE is a file name string to pass to `load'. + Third arg DOCSTRING is documentation for the function. -Fourth arg INTERACTIVE if non-nil says function can be called interactively. + +Fourth arg INTERACTIVE if non-nil says function can be called +interactively. If INTERACTIVE is a list, it is interpreted as a list +of modes the function is applicable for. + Fifth arg TYPE indicates the type of the object: nil or omitted says FUNCTION is a function, `keymap' says FUNCTION is really a keymap, and `macro' or t says FUNCTION is really a macro. + Third through fifth args give info about the real definition. They default to nil. + If FUNCTION is already defined other than as an autoload, this does nothing and returns nil. */) (Lisp_Object function, Lisp_Object file, Lisp_Object docstring, Lisp_Object interactive, Lisp_Object type) diff --git a/src/lisp.h b/src/lisp.h index 0847324d1ff..697dd89363c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2060,6 +2060,7 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; + Lisp_Object command_modes; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4221,6 +4222,8 @@ extern Lisp_Object module_function_documentation (struct Lisp_Module_Function const *); extern Lisp_Object module_function_interactive_form (const struct Lisp_Module_Function *); +extern Lisp_Object module_function_command_modes + (const struct Lisp_Module_Function *); extern module_funcptr module_function_address (struct Lisp_Module_Function const *); extern void *module_function_data (const struct Lisp_Module_Function *); diff --git a/src/lread.c b/src/lread.c index dea1b232fff..8b8ba93c607 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4467,6 +4467,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); + sname->command_modes = Qnil; } #ifdef NOTDEF /* Use fset in subr.el now! */ -- cgit v1.2.3 From 9291e7316f98ab0858b323f72047ffd5a23d9ac9 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:29:35 +0100 Subject: Add new 'declare' forms for command completion predicates * doc/lispref/functions.texi (Declare Form): Document the new `completion' and `modes' declarations. * lisp/simple.el (completion-with-modes-p): New helper functions. * lisp/emacs-lisp/byte-run.el (byte-run--set-completion) (byte-run--set-modes): (defun-declarations-alist): New declarations for `completion' and `modes'. --- doc/lispref/functions.texi | 10 ++++++++++ etc/NEWS | 9 +++++++++ lisp/emacs-lisp/byte-run.el | 15 ++++++++++++++- lisp/simple.el | 5 +++++ 4 files changed, 38 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index 414035f684b..1e3da8e3a5d 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -2309,6 +2309,16 @@ form @code{(lambda (@var{arg}) @var{body})} in which case that function will additionally have access to the macro (or function)'s arguments and it will be passed to @code{gv-define-setter}. +@item (completion @var{completion-predicate}) +Declare @var{completion-predicate} as a function to determine whether +to include the symbol in the list of functions when asking for +completions in @kbd{M-x}. @var{completion-predicate} is called with +two parameters: The first parameter is the symbol, and the second is +the current buffer. + +@item (modes @var{modes}) +Specify that this command is meant to be applicable for @var{modes} +only. @end table @end defmac diff --git a/etc/NEWS b/etc/NEWS index d8f0bc60726..3b6467bf45c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2266,6 +2266,15 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', * Lisp Changes in Emacs 28.1 ++++ +** New forms to declare how completion should happen has been added. +'(declare (completion PREDICATE))' can be used as a general predicate +to say whether the command should be present when completing with +'M-x TAB'. '(declare (modes MODE...))' can be used as a short-hand +way of saying that the command should be present when completing from +buffers in major modes derived from MODE..., or, if it's a minor mode, +whether that minor mode is enabled in the current buffer. + +++ ** The 'interactive' syntax has been extended to allow listing applicable modes. Forms like '(interactive "p" dired-mode)' can be used to annotate the diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 88f362d24f0..30fcbf2b9cc 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -143,6 +143,17 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''lisp-indent-function (list 'quote val)))) +(defalias 'byte-run--set-completion + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''completion-predicate val))) + +(defalias 'byte-run--set-modes + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''completion-predicate `(lambda (_ b) + (completion-with-modes-p ,val b))))) + ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list @@ -159,7 +170,9 @@ This may shift errors from run-time to compile-time.") If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") (list 'compiler-macro #'byte-run--set-compiler-macro) (list 'doc-string #'byte-run--set-doc-string) - (list 'indent #'byte-run--set-indent)) + (list 'indent #'byte-run--set-indent) + (list 'completion #'byte-run--set-completion) + (list 'modes #'byte-run--set-modes)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, diff --git a/lisp/simple.el b/lisp/simple.el index 0c5bcb66724..9057355a7ab 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1950,6 +1950,11 @@ to get different commands to edit and resubmit." (complete-with-action action obarray string pred))) #'commandp t nil 'extended-command-history))) +(defun completion-with-modes-p (modes buffer) + (apply #'provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + modes)) + (defun read-extended-command--affixation (command-names) (with-selected-window (or (minibuffer-selected-window) (selected-window)) (mapcar -- cgit v1.2.3 From 2bfcd93e83d264e6b801e43bfd1a78e345b8221d Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:31:10 +0100 Subject: Mark easy-menu-do-define menus as "not interesting" * lisp/emacs-lisp/easymenu.el (easy-menu-do-define): Mark menu keymaps as "not interesting" when doing completion. --- lisp/emacs-lisp/easymenu.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index 5303da3746c..39b3193b2f4 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -183,7 +183,10 @@ This is expected to be bound to a mouse event." :filter) 'identity) (symbol-function symbol))) - symbol))))) + symbol)))) + ;; These symbols are commands, but not interesting for users + ;; to `M-x TAB'. + (put symbol 'completion-predicate 'ignore)) (dolist (map (if (keymapp maps) (list maps) maps)) (define-key map (vector 'menu-bar (easy-menu-intern (car menu))) -- cgit v1.2.3 From c1ef7adeb649aa99a10c4bd3b6ce988b309da3cc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:56:53 +0100 Subject: Add 'read-extended-command-predicate' * doc/emacs/m-x.texi (M-x): Document it. * doc/lispref/commands.texi (Interactive Call): Document it further. * lisp/simple.el (read-extended-command-predicate): New user option. (read-extended-command-predicate): Use it. (completion-in-mode-p): New function (the default predicate). --- doc/emacs/m-x.texi | 5 ++ doc/lispref/commands.texi | 9 ++++ etc/NEWS | 5 ++ lisp/emacs-lisp/seq.el | 1 + lisp/simple.el | 131 +++++++++++++++++++++++++++++----------------- 5 files changed, 103 insertions(+), 48 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/emacs/m-x.texi b/doc/emacs/m-x.texi index 865220fb218..689125e7b4a 100644 --- a/doc/emacs/m-x.texi +++ b/doc/emacs/m-x.texi @@ -94,3 +94,8 @@ the command is followed by arguments. @kbd{M-x} works by running the command @code{execute-extended-command}, which is responsible for reading the name of another command and invoking it. + +@vindex read-extended-command-predicate + This command heeds the @code{read-extended-command-predicate} +variable, which will (by default) filter out commands that are not +applicable to the current major mode (or enabled minor modes). diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index d60745a825b..b3bcdf35c9f 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -773,6 +773,15 @@ part of the prompt. @result{} t @end group @end example + +@vindex read-extended-command-predicate +This command heeds the @code{read-extended-command-predicate} +variable, which will (by default) filter out commands that are not +applicable to the current major mode (or enabled minor modes). +@code{read-extended-command-predicate} will be called with two +parameters: The symbol that is to be included or not, and the current +buffer. If should return non-@code{nil} if the command is to be +included when completing. @end deffn @node Distinguish Interactive diff --git a/etc/NEWS b/etc/NEWS index 3b6467bf45c..9c3396d33af 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -251,6 +251,11 @@ commands. The new keystrokes are 'C-x x g' ('revert-buffer'), * Editing Changes in Emacs 28.1 ++++ +** New user option 'read-extended-command-predicate'. +This option controls how 'M-x TAB' performs completions. The default +predicate excludes modes for which the command is not applicable. + --- ** 'eval-expression' now no longer signals an error on incomplete expressions. Previously, typing 'M-: ( RET' would result in Emacs saying "End of diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 31c15fea90d..55ce6d9426d 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -455,6 +455,7 @@ negative integer or 0, nil is returned." (setq sequence (seq-drop sequence n))) (nreverse result)))) +;;;###autoload (cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." diff --git a/lisp/simple.el b/lisp/simple.el index 9057355a7ab..015fa9e4d55 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1900,55 +1900,90 @@ to get different commands to edit and resubmit." (defvar extended-command-history nil) (defvar execute-extended-command--last-typed nil) +(defcustom read-extended-command-predicate #'completion-in-mode-p + "Predicate to use to determine which commands to include when completing. +The predicate function is called with two parameter: The +symbol (i.e., command) in question that should be included or +not, and the current buffer. The predicate should return non-nil +if the command should be present when doing `M-x TAB'." + :version "28.1" + :type '(choice (const :tag "Exclude commands not relevant to this mode" + #'completion-in-mode-p) + (const :tag "All commands" (lambda (_ _) t)) + (function :tag "Other function"))) + (defun read-extended-command () - "Read command name to invoke in `execute-extended-command'." - (minibuffer-with-setup-hook - (lambda () - (add-hook 'post-self-insert-hook - (lambda () - (setq execute-extended-command--last-typed - (minibuffer-contents))) - nil 'local) - (setq-local minibuffer-default-add-function - (lambda () - ;; Get a command name at point in the original buffer - ;; to propose it after M-n. - (let ((def (with-current-buffer - (window-buffer (minibuffer-selected-window)) - (and (commandp (function-called-at-point)) - (format "%S" (function-called-at-point))))) - (all (sort (minibuffer-default-add-completions) - #'string<))) - (if def - (cons def (delete def all)) - all))))) - ;; Read a string, completing from and restricting to the set of - ;; all defined commands. Don't provide any initial input. - ;; Save the command read on the extended-command history list. - (completing-read - (concat (cond - ((eq current-prefix-arg '-) "- ") - ((and (consp current-prefix-arg) - (eq (car current-prefix-arg) 4)) "C-u ") - ((and (consp current-prefix-arg) - (integerp (car current-prefix-arg))) - (format "%d " (car current-prefix-arg))) - ((integerp current-prefix-arg) - (format "%d " current-prefix-arg))) - ;; This isn't strictly correct if `execute-extended-command' - ;; is bound to anything else (e.g. [menu]). - ;; It could use (key-description (this-single-command-keys)), - ;; but actually a prompt other than "M-x" would be confusing, - ;; because "M-x" is a well-known prompt to read a command - ;; and it serves as a shorthand for "Extended command: ". - "M-x ") - (lambda (string pred action) - (if (and suggest-key-bindings (eq action 'metadata)) - '(metadata - (affixation-function . read-extended-command--affixation) - (category . command)) - (complete-with-action action obarray string pred))) - #'commandp t nil 'extended-command-history))) + "Read command name to invoke in `execute-extended-command'. +This function uses the `read-extended-command-predicate' user option." + (let ((buffer (current-buffer))) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'post-self-insert-hook + (lambda () + (setq execute-extended-command--last-typed + (minibuffer-contents))) + nil 'local) + (setq-local minibuffer-default-add-function + (lambda () + ;; Get a command name at point in the original buffer + ;; to propose it after M-n. + (let ((def + (with-current-buffer + (window-buffer (minibuffer-selected-window)) + (and (commandp (function-called-at-point)) + (format + "%S" (function-called-at-point))))) + (all (sort (minibuffer-default-add-completions) + #'string<))) + (if def + (cons def (delete def all)) + all))))) + ;; Read a string, completing from and restricting to the set of + ;; all defined commands. Don't provide any initial input. + ;; Save the command read on the extended-command history list. + (completing-read + (concat (cond + ((eq current-prefix-arg '-) "- ") + ((and (consp current-prefix-arg) + (eq (car current-prefix-arg) 4)) "C-u ") + ((and (consp current-prefix-arg) + (integerp (car current-prefix-arg))) + (format "%d " (car current-prefix-arg))) + ((integerp current-prefix-arg) + (format "%d " current-prefix-arg))) + ;; This isn't strictly correct if `execute-extended-command' + ;; is bound to anything else (e.g. [menu]). + ;; It could use (key-description (this-single-command-keys)), + ;; but actually a prompt other than "M-x" would be confusing, + ;; because "M-x" is a well-known prompt to read a command + ;; and it serves as a shorthand for "Extended command: ". + "M-x ") + (lambda (string pred action) + (if (and suggest-key-bindings (eq action 'metadata)) + '(metadata + (affixation-function . read-extended-command--affixation) + (category . command)) + (complete-with-action action obarray string pred))) + (lambda (sym) + (and (commandp sym) + (if (get sym 'completion-predicate) + (funcall (get sym 'completion-predicate) sym buffer) + (funcall read-extended-command-predicate sym buffer)))) + t nil 'extended-command-history)))) + +(defun completion-in-mode-p (symbol buffer) + "Say whether SYMBOL should be offered as a completion. +This is true if the command is applicable to the major mode in +BUFFER." + (or (null (command-modes symbol)) + ;; It's derived from a major mode. + (apply #'provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + (command-modes symbol)) + ;; It's a minor mode. + (seq-intersection (command-modes symbol) + (buffer-local-value 'minor-modes buffer) + #'eq))) (defun completion-with-modes-p (modes buffer) (apply #'provided-mode-derived-p -- cgit v1.2.3 From 40f7804ecb299a7f7c3accd19d27e2898d3b8374 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 14:06:16 +0100 Subject: Allow define-minor-mode to take an :interactive keyword * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Allow specifying the :interactive state and the modes. --- etc/NEWS | 8 +++++++- lisp/emacs-lisp/easy-mmode.el | 22 +++++++++++++++++----- 2 files changed, 24 insertions(+), 6 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/etc/NEWS b/etc/NEWS index 9c3396d33af..22c320bfa31 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2294,7 +2294,13 @@ This permanently buffer-local variable holds a list of currently enabled minor modes in the current buffer (as a list of symbols). +++ -** 'defined-derived-mode' now takes an :interactive argument. +** 'define-minor-mode' now takes an :interactive argument. +This can be used for specifying which modes this minor mode is meant +for, or to make the new minor mode non-interactive. The default value +is t. + ++++ +** 'define-derived-mode' now takes an :interactive argument. This can be used to control whether the defined mode is a command or not, and is useful when defining commands that aren't meant to be used by users directly. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index bfffbe4bf20..08ac8186949 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -172,6 +172,10 @@ BODY contains code to execute each time the mode is enabled or disabled. :lighter SPEC Same as the LIGHTER argument. :keymap MAP Same as the KEYMAP argument. :require SYM Same as in `defcustom'. +:interactive VAL Whether this mode should be a command or not. The default + is to make it one; use nil to avoid that. If VAL is a list, + it's interpreted as a list of major modes this minor mode + is useful in. :variable PLACE The location to use instead of the variable MODE to store the state of the mode. This can be simply a different named variable, or a generalized variable. @@ -226,6 +230,7 @@ For example, you could write (hook (intern (concat mode-name "-hook"))) (hook-on (intern (concat mode-name "-on-hook"))) (hook-off (intern (concat mode-name "-off-hook"))) + (interactive t) keyw keymap-sym tmp) ;; Check keys. @@ -245,6 +250,7 @@ For example, you could write (:type (setq type (list :type (pop body)))) (:require (setq require (pop body))) (:keymap (setq keymap (pop body))) + (:interactive (setq interactive (pop body))) (:variable (setq variable (pop body)) (if (not (and (setq tmp (cdr-safe variable)) (or (symbolp tmp) @@ -303,11 +309,17 @@ or call the function `%s'.")))) ;; The actual function. (defun ,modefun (&optional arg ,@extra-args) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym) - ;; Use `toggle' rather than (if ,mode 0 1) so that using - ;; repeat-command still does the toggling correctly. - (interactive (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - 'toggle))) + ,(when interactive + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + (if (consp interactive) + `(command ,interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))) + '(interactive (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))))) (let ((,last-message (current-message))) (,@setter (cond ((eq arg 'toggle) -- cgit v1.2.3 From 07e6b29b12c961808fcf4d8f804946056118efc5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 14:12:08 +0100 Subject: Fix previous define-minor-mode change * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Fix interactive extension in previous change. --- lisp/emacs-lisp/easy-mmode.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 08ac8186949..01fb58e863a 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -313,10 +313,11 @@ or call the function `%s'.")))) ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. (if (consp interactive) - `(command ,interactive - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - 'toggle))) + `(interactive + ,interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))) '(interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) 'toggle))))) -- cgit v1.2.3 From 869cdcf4e7a787534d275ca6fc0a792ab642c764 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 14:13:38 +0100 Subject: Really fix the syntax problem in define-minor-mode * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Fix interactive extension in previous change. --- lisp/emacs-lisp/easy-mmode.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 01fb58e863a..7e5e2a9b8a9 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -314,10 +314,10 @@ or call the function `%s'.")))) ;; repeat-command still does the toggling correctly. (if (consp interactive) `(interactive - ,interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) - 'toggle))) + 'toggle)) + ,@interactive) '(interactive (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg) 'toggle))))) -- cgit v1.2.3 From 2f00a3435a05bbcedbf8851baeefd33463bc525b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 16:51:14 +0100 Subject: Don't update `minor-modes' in global modes * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): There's no point in setting the buffer-local `minor-modes' in global modes. --- lisp/emacs-lisp/easy-mmode.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 7e5e2a9b8a9..5ba0d2187f2 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -330,10 +330,11 @@ or call the function `%s'.")))) nil) (t t))) - ;; Keep `minor-modes' up to date. - (setq minor-modes (delq ',modefun minor-modes)) - (when ,getter - (push ',modefun minor-modes)) + (unless ,globalp + ;; Keep `minor-modes' up to date. + (setq minor-modes (delq ',modefun minor-modes)) + (when ,getter + (push ',modefun minor-modes))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) -- cgit v1.2.3 From c3396917725a537e9060f2144b6907ab870b22dd Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 18:01:06 +0100 Subject: Fix byte-run--set-modes call signature * lisp/emacs-lisp/byte-run.el (byte-run--set-modes): We take a list of modes, not a single one (and fix the quoting). --- lisp/emacs-lisp/byte-run.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 30fcbf2b9cc..48a7fe80615 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -149,10 +149,10 @@ The return value of this function is not used." ''completion-predicate val))) (defalias 'byte-run--set-modes - #'(lambda (f _args val) + #'(lambda (f _args &rest val) (list 'function-put (list 'quote f) ''completion-predicate `(lambda (_ b) - (completion-with-modes-p ,val b))))) + (completion-with-modes-p ',val b))))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist -- cgit v1.2.3 From b939f7ad359807e846831a9854e0d94260d9f084 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 14 Feb 2021 21:13:35 -0500 Subject: * Edebug: Generalize `&lookup`, use it for `cl-macrolet` and `cl-generic` This allows the use of (declare (debug ...)) in the lexical macros defined with `cl-macrolet`. It also fixes the names used by Edebug for the methods of `cl-generic` so it doesn't need to use gensym and so they don't include the formal arg names any more. * lisp/emacs-lisp/edebug.el (edebug--match-&-spec-op): Rename from `edebug--handle-&-spec-op`. (edebug--match-&-spec-op <&interpose>): Rename from `&lookup` and generalize so it can let-bind dynamic variables around the rest of the parse. (edebug-lexical-macro-ctx): Rename from `edebug--cl-macrolet-defs` and make it into an alist. (edebug-list-form-args): Use the specs from `edebug-lexical-macro-ctx` when available. (edebug--current-cl-macrolet-defs): Delete var. (edebug-match-cl-macrolet-expr, edebug-match-cl-macrolet-name) (edebug-match-cl-macrolet-body): Delete functions. (def-declarations): Use new `&interpose`. (edebug--match-declare-arg): Rename from `edebug--get-declare-spec` and adjust to new calling convention. * lisp/subr.el (def-edebug-elem-spec): Fix docstring. (eval-after-load): Use `declare`. * lisp/emacs-lisp/cl-generic.el: Fix Edebug names so we don't need gensym any more and we only include the specializers but not the formal arg names. (cl--generic-edebug-name): New var. (cl--generic-edebug-remember-name, cl--generic-edebug-make-name): New funs. (cl-defgeneric, cl-defmethod): Use them. * lisp/emacs-lisp/cl-macs.el: Add support for `debug` declarations in `cl-macrolet`. (cl-declarations-or-string): Fix use of `lambda-doc` and allow use of `declare`. (edebug-lexical-macro-ctx): Declare var. (cl--edebug-macrolet-interposer): New function. (cl-macrolet): Use it to pass the right `lexical-macro-ctx` to the body. * lisp/emacs-lisp/pcase.el (pcase-PAT): Use new `&interpose`. (pcase--edebug-match-pat-args): Rename from `pcase--get-edebug-spec` and adjust to new calling convention. * test/lisp/emacs-lisp/cl-generic-tests.el (cl-defgeneric/edebug/method): Adjust to the new names. * test/lisp/emacs-lisp/edebug-tests.el (edebug-cl-defmethod-qualifier) (edebug-tests-cl-flet): Adjust to the new names. * doc/lispref/edebug.texi (Specification List): Document &interpose. --- doc/lispref/edebug.texi | 22 ++-- etc/NEWS | 5 +- lisp/emacs-lisp/cl-generic.el | 76 ++++++----- lisp/emacs-lisp/cl-macs.el | 24 +++- lisp/emacs-lisp/edebug.el | 114 ++++++---------- lisp/emacs-lisp/pcase.el | 8 +- lisp/subr.el | 143 ++++++++++----------- test/lisp/emacs-lisp/cl-generic-tests.el | 12 +- .../edebug-resources/edebug-test-code.el | 4 +- test/lisp/emacs-lisp/edebug-tests.el | 24 ++-- 10 files changed, 218 insertions(+), 214 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 46f5cb9026a..3868f675ead 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1362,16 +1362,20 @@ is primarily used to generate more specific syntax error messages. See edebug-spec; it aborts the instrumentation, displaying the message in the minibuffer. -@item &lookup -Selects a specification based on the code being instrumented. -It takes the form @code{&lookup @var{spec} @var{fun} @var{args...}} +@item &interpose +Lets a function control the parsing of the remaining code. +It takes the form @code{&interpose @var{spec} @var{fun} @var{args...}} and means that Edebug will first match @var{spec} against the code and -then match the rest against the specification returned by calling -@var{fun} with the concatenation of @var{args...} and the code that -matched @code{spec}. For example @code{(&lookup symbolp -pcase--get-edebug-spec)} matches sexps whose first element is -a symbol and whose subsequent elements must obey the spec associated -with that head symbol according to @code{pcase--get-edebug-spec}. +then call @var{fun} with the code that matched @code{spec}, a parsing +function var{pf}, and finally @var{args...}. The parsing +function expects a single argument indicating the specification list +to use to parse the remaining code. It should be called exactly once +and returns the instrumented code that @var{fun} is expected to return. +For example @code{(&interpose symbolp pcase--match-pat-args)} matches +sexps whose first element is a symbol and then lets +@code{pcase--match-pat-args} lookup the specs associated +with that head symbol according to @code{pcase--match-pat-args} and +pass them to the var{pf} it received as argument. @item @var{other-symbol} @cindex indirect specifications diff --git a/etc/NEWS b/etc/NEWS index 33434d598ab..1adfb8c5bb1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -959,7 +959,10 @@ declared obsolete. *** Edebug specification lists can use some new keywords: +++ -**** '&lookup SPEC FUN ARGS...' lets FUN compute the specs to use +**** '&interpose SPEC FUN ARGS..' lets FUN control parsing after SPEC. +More specifically, FUN is called with 'HEAD PF ARGS..' where +PF is a parsing function that expects a single argument (the specs to +use) and HEAD is the code that matched SPEC. +++ **** '&error MSG' unconditionally aborts the current edebug instrumentation. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 229608395eb..279b9d137c9 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) +(defvar cl--generic-edebug-name nil) + +(defun cl--generic-edebug-remember-name (name pf &rest specs) + ;; Remember the name in `cl-defgeneric' so we can use it when building + ;; the names of its `:methods'. + (let ((cl--generic-edebug-name (car name))) + (funcall pf specs))) + +(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args) + ;; The name to use in Edebug for a method: use the generic + ;; function's name plus all its qualifiers and finish with + ;; its specializers. + (pcase-let* + ((basename (if in:method cl--generic-edebug-name (pop quals-and-args))) + (args (car (last quals-and-args))) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args))) + (format "%s %s" + (mapconcat (lambda (sexp) (format "%s" sexp)) + (cons basename (butlast quals-and-args)) + " ") + specializers))) + ;;;###autoload (defmacro cl-defgeneric (name args &rest options-and-methods) "Create a generic function NAME. @@ -206,31 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method. \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3) (debug - (&define [&name sexp] ;Allow (setf ...) additionally to symbols. - listp lambda-doc - [&rest [&or - ("declare" &rest sexp) - (":argument-precedence-order" &rest sexp) - (&define ":method" - ;; FIXME: The `gensym' - ;; construct works around - ;; Bug#42672. We'd rather want - ;; names like those generated by - ;; `cl-defmethod', but that - ;; requires larger changes to - ;; Edebug. - [&name "cl-generic-:method@" []] - [&name [] gensym] ;Make it unique! - [&name - [[&rest cl-generic--method-qualifier-p] - ;; FIXME: We don't actually want the - ;; argument's names to be considered - ;; part of the name of the defined - ;; function. - listp]] ;Formal args - lambda-doc - def-body)]] - def-body))) + (&define + &interpose + [&name sexp] ;Allow (setf ...) additionally to symbols. + cl--generic-edebug-remember-name + listp lambda-doc + [&rest [&or + ("declare" &rest sexp) + (":argument-precedence-order" &rest sexp) + (&define ":method" + [&name + [[&rest cl-generic--method-qualifier-p] + listp] ;Formal args + cl--generic-edebug-make-name in:method] + lambda-doc + def-body)]] + def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) (declarations nil) @@ -451,12 +468,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (debug (&define ; this means we are defining something [&name [sexp ;Allow (setf ...) additionally to symbols. - ;; Multiple qualifiers are allowed. - [&rest cl-generic--method-qualifier-p] - ;; FIXME: We don't actually want the argument's names - ;; to be considered part of the name of the - ;; defined function. - listp]] ; arguments + [&rest cl-generic--method-qualifier-p] ;qualifiers + listp] ; arguments + cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e2faf6df534..b9a8a3f1125 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -190,7 +190,7 @@ The name is made by appending a number to PREFIX, default \"T\"." '(&rest ("cl-declare" &rest sexp))) (def-edebug-elem-spec 'cl-declarations-or-string - '(&or lambda-doc cl-declarations)) + '(lambda-doc &or ("declare" def-declarations) cl-declarations)) (def-edebug-elem-spec 'cl-lambda-list '(([&rest cl-lambda-arg] @@ -2193,6 +2193,20 @@ details. (macroexp-progn body) newenv))))) +(defvar edebug-lexical-macro-ctx) + +(defun cl--edebug-macrolet-interposer (bindings pf &rest specs) + ;; (cl-assert (null (cdr bindings))) + (setq bindings (car bindings)) + (let ((edebug-lexical-macro-ctx + (nconc (mapcar (lambda (binding) + (cons (car binding) + (when (eq 'declare (car-safe (nth 2 binding))) + (nth 1 (assq 'debug (cdr (nth 2 binding))))))) + bindings) + edebug-lexical-macro-ctx))) + (funcall pf specs))) + ;; The following ought to have a better definition for use with newer ;; byte compilers. ;;;###autoload @@ -2202,7 +2216,13 @@ This is like `cl-flet', but for macros instead of functions. \(fn ((NAME ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug (cl-macrolet-expr))) + (debug (&interpose (&rest (&define [&name symbolp "@cl-macrolet@"] + [&name [] gensym] ;Make it unique! + cl-macro-list + cl-declarations-or-string + def-body)) + cl--edebug-macrolet-interposer + cl-declarations body))) (if (cdr bindings) `(cl-macrolet (,(car bindings)) (cl-macrolet ,(cdr bindings) ,@body)) (if (null bindings) (macroexp-progn body) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 8fadeba6c9a..efca7305fea 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1188,6 +1188,9 @@ purpose by adding an entry to this alist, and setting ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) (let ((result (cond + ;; IIUC, `&define' is treated specially here so as to avoid + ;; entering Edebug during the actual function's definition: + ;; we only want to enter Edebug later when the thing is called. (defining-form-p (if (or edebug-all-defs edebug-all-forms) ;; If it is a defining form and we are edebugging defs, @@ -1238,7 +1241,9 @@ purpose by adding an entry to this alist, and setting (defvar edebug-inside-func) ;; whether code is inside function context. ;; Currently def-form sets this to nil; def-body sets it to t. -(defvar edebug--cl-macrolet-defs) ;; Fully defined below. + +(defvar edebug-lexical-macro-ctx nil + "Alist mapping lexically scoped macro names to their debug spec.") (defun edebug-make-enter-wrapper (forms) ;; Generate the enter wrapper for some forms of a definition. @@ -1549,13 +1554,10 @@ contains a circular object." (defsubst edebug-list-form-args (head cursor) ;; Process the arguments of a list form given that head of form is a symbol. ;; Helper for edebug-list-form - (let ((spec (edebug-get-spec head))) + (let* ((lex-spec (assq head edebug-lexical-macro-ctx)) + (spec (if lex-spec (cdr lex-spec) + (edebug-get-spec head)))) (cond - ;; Treat cl-macrolet bindings like macros with no spec. - ((member head edebug--cl-macrolet-defs) - (if edebug-eval-macro-args - (edebug-forms cursor) - (edebug-sexps cursor))) (spec (cond ((consp spec) @@ -1569,7 +1571,7 @@ contains a circular object." ; but leave it in for compatibility. )) ;; No edebug-form-spec provided. - ((macrop head) + ((or lex-spec (macrop head)) (if edebug-eval-macro-args (edebug-forms cursor) (edebug-sexps cursor))) @@ -1689,7 +1691,7 @@ contains a circular object." (first-char (and (symbolp spec) (aref (symbol-name spec) 0))) (match (cond ((eq ?& first-char);; "&" symbols take all following specs. - (edebug--handle-&-spec-op spec cursor (cdr specs))) + (edebug--match-&-spec-op spec cursor (cdr specs))) ((eq ?: first-char);; ":" symbols take one following spec. (setq rest (cdr (cdr specs))) (edebug--handle-:-spec-op spec cursor (car (cdr specs)))) @@ -1731,9 +1733,6 @@ contains a circular object." (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) - (cl-macrolet-expr . edebug-match-cl-macrolet-expr) - (cl-macrolet-name . edebug-match-cl-macrolet-name) - (cl-macrolet-body . edebug-match-cl-macrolet-body) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. @@ -1781,7 +1780,7 @@ contains a circular object." (defsubst edebug-match-body (cursor) (edebug-forms cursor)) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &optional)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &optional)) cursor specs) ;; Keep matching until one spec fails. (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) @@ -1807,11 +1806,11 @@ contains a circular object." ;; Reuse the &optional handler with this as the remainder handler. (edebug-&optional-wrapper cursor specs remainder-handler)) -(cl-defgeneric edebug--handle-&-spec-op (op cursor specs) +(cl-defgeneric edebug--match-&-spec-op (op cursor specs) "Handle &foo spec operators. &foo spec operators operate on all the subsequent SPECS.") -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &rest)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &rest)) cursor specs) ;; Repeatedly use specs until failure. (let ((edebug-&rest specs) ;; remember these edebug-best-error @@ -1819,7 +1818,7 @@ contains a circular object." (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &or)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &or)) cursor specs) ;; Keep matching until one spec succeeds, and return its results. ;; If none match, fail. ;; This needs to be optimized since most specs spend time here. @@ -1843,40 +1842,48 @@ contains a circular object." (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &lookup)) cursor specs) - "Compute the specs for `&lookup SPEC FUN ARGS...'. +(cl-defmethod edebug--match-&-spec-op ((_ (eql &interpose)) cursor specs) + "Compute the specs for `&interpose SPEC FUN ARGS...'. Extracts the head of the data by matching it against SPEC, -and then matches the rest against the output of (FUN ARGS... HEAD)." +and then matches the rest by calling (FUN HEAD PF ARGS...) +where PF is the parsing function which FUN can call exactly once, +passing it the specs that it needs to match. +Note that HEAD will always be a list, since specs are defined to match +a sequence of elements." (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) (instrumented-head (edebug-match-one-spec cursor spec)) (consumed (- (length exps) (length (edebug-cursor-expressions cursor)))) - (newspecs (apply fun (append args (seq-subseq exps 0 consumed))))) + (head (seq-subseq exps 0 consumed))) (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) - ;; FIXME: What'd be the difference if we used `edebug-match-sublist', - ;; which is what `edebug-list-form-args' uses for the similar purpose - ;; when matching "normal" forms? - (append instrumented-head (edebug-match cursor newspecs)))) - -(cl-defmethod edebug--handle-&-spec-op ((_ (eql ¬)) cursor specs) + (apply fun `(,head + ,(lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + ,@args)))) + +(cl-defmethod edebug--match-&-spec-op ((_ (eql ¬)) cursor specs) ;; If any specs match, then fail (if (null (catch 'no-match (let ((edebug-gate nil)) (save-excursion - (edebug--handle-&-spec-op '&or cursor specs))) + (edebug--match-&-spec-op '&or cursor specs))) nil)) ;; This means something matched, so it is a no match. (edebug-no-match cursor "Unexpected")) ;; This means nothing matched, so it is OK. nil) ;; So, return nothing -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &key)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &key)) cursor specs) ;; Following specs must look like ( ) ... ;; where is the name of a keyword, and spec is its spec. ;; This really doesn't save much over the expanded form and takes time. - (edebug--handle-&-spec-op + (edebug--match-&-spec-op '&rest cursor (cons '&or @@ -1885,7 +1892,7 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." (car (cdr pair)))) specs)))) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &error)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &error)) cursor specs) ;; Signal an error, using the following string in the spec as argument. (let ((error-string (car specs)) (edebug-error-point (edebug-before-offset cursor))) @@ -1989,7 +1996,7 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." (defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &define)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &define)) cursor specs) ;; Match a defining form. ;; Normally, &define is interpreted specially other places. ;; This should only be called inside of a spec list to match the remainder @@ -2003,7 +2010,7 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." offsets) specs)) -(cl-defmethod edebug--handle-&-spec-op ((_ (eql &name)) cursor specs) +(cl-defmethod edebug--match-&-spec-op ((_ (eql &name)) cursor specs) "Compute the name for `&name SPEC FUN` spec operator. The full syntax of that operator is: @@ -2083,43 +2090,6 @@ SPEC is the symbol name prefix for `gensym'." suffix))) nil) -(defvar edebug--cl-macrolet-defs nil - "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") -(defvar edebug--current-cl-macrolet-defs nil - "List of symbols found within the bindings of the current `cl-macrolet' form.") - -(defun edebug-match-cl-macrolet-expr (cursor) - "Match a `cl-macrolet' form at CURSOR." - (let (edebug--current-cl-macrolet-defs) - (edebug-match cursor - '((&rest (&define cl-macrolet-name cl-macro-list - cl-declarations-or-string - def-body)) - cl-declarations cl-macrolet-body)))) - -(defun edebug-match-cl-macrolet-name (cursor) - "Match the name in a `cl-macrolet' binding at CURSOR. -Collect the names in `edebug--cl-macrolet-defs' where they -will be checked by `edebug-list-form-args' and treated as -macros without a spec." - (let ((name (edebug-top-element-required cursor "Expected name"))) - (when (not (symbolp name)) - (edebug-no-match cursor "Bad name:" name)) - ;; Change edebug-def-name to avoid conflicts with - ;; names at global scope. - (setq edebug-def-name (gensym "edebug-anon")) - (edebug-move-cursor cursor) - (push name edebug--current-cl-macrolet-defs) - (list name))) - -(defun edebug-match-cl-macrolet-body (cursor) - "Match the body of a `cl-macrolet' expression at CURSOR. -Put the definitions collected in `edebug--current-cl-macrolet-defs' -into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." - (let ((edebug--cl-macrolet-defs (nconc edebug--current-cl-macrolet-defs - edebug--cl-macrolet-defs))) - (edebug-match-body cursor))) - (defun edebug-match-arg (cursor) ;; set the def-args bound in edebug-defining-form (let ((edebug-arg (edebug-top-element-required cursor "Expected arg"))) @@ -2210,11 +2180,11 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." )) (put name 'edebug-form-spec spec)) -(defun edebug--get-declare-spec (head) - (get head 'edebug-declaration-spec)) +(defun edebug--match-declare-arg (head pf) + (funcall pf (get (car head) 'edebug-declaration-spec))) (def-edebug-elem-spec 'def-declarations - '(&rest &or (&lookup symbolp edebug--get-declare-spec) sexp)) + '(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp)) (def-edebug-elem-spec 'lambda-list '(([&rest arg] diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 5d428ac846a..d3928fa5051 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -63,7 +63,7 @@ (defvar pcase--dontwarn-upats '(pcase--dontcare)) (def-edebug-elem-spec 'pcase-PAT - '(&or (&lookup symbolp pcase--get-edebug-spec) sexp)) + '(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp)) (def-edebug-elem-spec 'pcase-FUN '(&or lambda-expr @@ -73,7 +73,9 @@ ;; Only called from edebug. (declare-function edebug-get-spec "edebug" (symbol)) -(defun pcase--get-edebug-spec (head) +(defun pcase--edebug-match-pat-args (head pf) + ;; (cl-assert (null (cdr head))) + (setq head (car head)) (or (alist-get head '((quote sexp) (or &rest pcase-PAT) (and &rest pcase-PAT) @@ -81,7 +83,7 @@ (pred &or ("not" pcase-FUN) pcase-FUN) (app pcase-FUN pcase-PAT))) (let ((me (pcase--get-macroexpander head))) - (and me (symbolp me) (edebug-get-spec me))))) + (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil" diff --git a/lisp/subr.el b/lisp/subr.el index d215bd29a91..490aec93f19 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -64,8 +64,8 @@ For more information, see Info node `(elisp)Declaring Functions'." ;;;; Basic Lisp macros. -(defalias 'not 'null) -(defalias 'sxhash 'sxhash-equal) +(defalias 'not #'null) +(defalias 'sxhash #'sxhash-equal) (defmacro noreturn (form) "Evaluate FORM, expecting it not to return. @@ -93,10 +93,7 @@ Info node `(elisp)Specification List' for details." (defun def-edebug-elem-spec (name spec) "Define a new Edebug spec element NAME as shorthand for SPEC. -The SPEC has to be a list or a symbol. -The elements of the list describe the argument types; see -Info node `(elisp)Specification List' for details. -If SPEC is a symbol it should name another pre-existing Edebug element." +The SPEC has to be a list." (declare (indent 1)) (when (string-match "\\`[&:]" (symbol-name name)) ;; & and : have special meaning in spec element names. @@ -788,7 +785,7 @@ If TEST is omitted or nil, `equal' is used." (let (found (tail alist) value) (while (and tail (not found)) (let ((elt (car tail))) - (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) + (when (funcall (or test #'equal) (if (consp elt) (car elt) elt) key) (setq found t value (if (consp elt) (cdr elt) default)))) (setq tail (cdr tail))) value)) @@ -938,14 +935,14 @@ For an approximate inverse of this, see `key-description'." "Make MAP override all normally self-inserting keys to be undefined. Normally, as an exception, digits and minus-sign are set to make prefix args, but optional second arg NODIGITS non-nil treats them like other chars." - (define-key map [remap self-insert-command] 'undefined) + (define-key map [remap self-insert-command] #'undefined) (or nodigits (let (loop) - (define-key map "-" 'negative-argument) + (define-key map "-" #'negative-argument) ;; Make plain numbers do numeric args. (setq loop ?0) (while (<= loop ?9) - (define-key map (char-to-string loop) 'digit-argument) + (define-key map (char-to-string loop) #'digit-argument) (setq loop (1+ loop)))))) (defun make-composed-keymap (maps &optional parent) @@ -982,8 +979,8 @@ a menu, so this function is not useful for non-menu keymaps." (setq key (if (<= (length key) 1) (aref key 0) (setq keymap (lookup-key keymap - (apply 'vector - (butlast (mapcar 'identity key))))) + (apply #'vector + (butlast (mapcar #'identity key))))) (aref key (1- (length key))))) (let ((tail keymap) done inserted) (while (and (not done) tail) @@ -1111,7 +1108,7 @@ Subkeymaps may be modified but are not canonicalized." (push (cons key item) bindings))) map))) ;; Create the new map. - (setq map (funcall (if ranges 'make-keymap 'make-sparse-keymap) prompt)) + (setq map (funcall (if ranges #'make-keymap #'make-sparse-keymap) prompt)) (dolist (binding ranges) ;; Treat char-ranges specially. FIXME: need to merge as well. (define-key map (vector (car binding)) (cdr binding))) @@ -1750,29 +1747,29 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Alternate names for functions - these are not being phased out. -(defalias 'send-string 'process-send-string) -(defalias 'send-region 'process-send-region) -(defalias 'string= 'string-equal) -(defalias 'string< 'string-lessp) -(defalias 'string> 'string-greaterp) -(defalias 'move-marker 'set-marker) -(defalias 'rplaca 'setcar) -(defalias 'rplacd 'setcdr) -(defalias 'beep 'ding) ;preserve lingual purity -(defalias 'indent-to-column 'indent-to) -(defalias 'backward-delete-char 'delete-backward-char) +(defalias 'send-string #'process-send-string) +(defalias 'send-region #'process-send-region) +(defalias 'string= #'string-equal) +(defalias 'string< #'string-lessp) +(defalias 'string> #'string-greaterp) +(defalias 'move-marker #'set-marker) +(defalias 'rplaca #'setcar) +(defalias 'rplacd #'setcdr) +(defalias 'beep #'ding) ;preserve lingual purity +(defalias 'indent-to-column #'indent-to) +(defalias 'backward-delete-char #'delete-backward-char) (defalias 'search-forward-regexp (symbol-function 're-search-forward)) (defalias 'search-backward-regexp (symbol-function 're-search-backward)) -(defalias 'int-to-string 'number-to-string) -(defalias 'store-match-data 'set-match-data) -(defalias 'chmod 'set-file-modes) -(defalias 'mkdir 'make-directory) +(defalias 'int-to-string #'number-to-string) +(defalias 'store-match-data #'set-match-data) +(defalias 'chmod #'set-file-modes) +(defalias 'mkdir #'make-directory) ;; These are the XEmacs names: -(defalias 'point-at-eol 'line-end-position) -(defalias 'point-at-bol 'line-beginning-position) +(defalias 'point-at-eol #'line-end-position) +(defalias 'point-at-bol #'line-beginning-position) (define-obsolete-function-alias 'user-original-login-name - 'user-login-name "28.1") + #'user-login-name "28.1") ;;;; Hook manipulation functions. @@ -1886,7 +1883,7 @@ one will be removed." (if local "Buffer-local" "Global")) fn-alist nil t) - fn-alist nil nil 'string=))) + fn-alist nil nil #'string=))) (list hook function local))) (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) @@ -2098,9 +2095,9 @@ can do the job." (if (cond ((null compare-fn) (member element (symbol-value list-var))) - ((eq compare-fn 'eq) + ((eq compare-fn #'eq) (memq element (symbol-value list-var))) - ((eq compare-fn 'eql) + ((eq compare-fn #'eql) (memql element (symbol-value list-var))) (t (let ((lst (symbol-value list-var))) @@ -2532,7 +2529,7 @@ program before the output is collected. If STATUS-HANDLER is NIL, an error is signalled if the program returns with a non-zero exit status." (with-temp-buffer - (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (let ((status (apply #'call-process program nil (current-buffer) nil args))) (if status-handler (funcall status-handler status) (unless (eq status 0) @@ -2578,7 +2575,7 @@ process." (format "Buffer %S has a running process; kill it? " (buffer-name (current-buffer))))))) -(add-hook 'kill-buffer-query-functions 'process-kill-buffer-query-function) +(add-hook 'kill-buffer-query-functions #'process-kill-buffer-query-function) ;; process plist management @@ -2766,7 +2763,7 @@ by doing (clear-string STRING)." (use-local-map read-passwd-map) (setq-local inhibit-modification-hooks nil) ;bug#15501. (setq-local show-paren-mode nil) ;bug#16091. - (add-hook 'post-command-hook 'read-password--hide-password nil t)) + (add-hook 'post-command-hook #'read-password--hide-password nil t)) (unwind-protect (let ((enable-recursive-minibuffers t) (read-hide-char (or read-hide-char ?*))) @@ -2776,8 +2773,8 @@ by doing (clear-string STRING)." ;; Not sure why but it seems that there might be cases where the ;; minibuffer is not always properly reset later on, so undo ;; whatever we've done here (bug#11392). - (remove-hook 'after-change-functions 'read-password--hide-password - 'local) + (remove-hook 'after-change-functions + #'read-password--hide-password 'local) (kill-local-variable 'post-self-insert-hook) ;; And of course, don't keep the sensitive data around. (erase-buffer)))))))) @@ -2807,7 +2804,7 @@ This function is used by the `interactive' code letter `n'." prompt nil nil nil (or hist 'read-number-history) (when default (if (consp default) - (mapcar 'number-to-string (delq nil default)) + (mapcar #'number-to-string (delq nil default)) (number-to-string default)))))) (condition-case nil (setq n (cond @@ -2961,13 +2958,13 @@ If there is a natural number at point, use it as default." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map [remap self-insert-command] 'read-char-from-minibuffer-insert-char) + (define-key map [remap self-insert-command] #'read-char-from-minibuffer-insert-char) - (define-key map [remap recenter-top-bottom] 'minibuffer-recenter-top-bottom) - (define-key map [remap scroll-up-command] 'minibuffer-scroll-up-command) - (define-key map [remap scroll-down-command] 'minibuffer-scroll-down-command) - (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window) - (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down) + (define-key map [remap recenter-top-bottom] #'minibuffer-recenter-top-bottom) + (define-key map [remap scroll-up-command] #'minibuffer-scroll-up-command) + (define-key map [remap scroll-down-command] #'minibuffer-scroll-down-command) + (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) + (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) map) "Keymap for the `read-char-from-minibuffer' function.") @@ -3030,9 +3027,9 @@ There is no need to explicitly add `help-char' to CHARS; (help-form-show))))) (dolist (char chars) (define-key map (vector char) - 'read-char-from-minibuffer-insert-char)) + #'read-char-from-minibuffer-insert-char)) (define-key map [remap self-insert-command] - 'read-char-from-minibuffer-insert-other) + #'read-char-from-minibuffer-insert-other) (puthash (list help-form (cons help-char chars)) map read-char-from-minibuffer-map-hash) map)) @@ -3065,26 +3062,26 @@ There is no need to explicitly add `help-char' to CHARS; (set-keymap-parent map minibuffer-local-map) (dolist (symbol '(act act-and-show act-and-exit automatic)) - (define-key map (vector 'remap symbol) 'y-or-n-p-insert-y)) + (define-key map (vector 'remap symbol) #'y-or-n-p-insert-y)) - (define-key map [remap skip] 'y-or-n-p-insert-n) + (define-key map [remap skip] #'y-or-n-p-insert-n) (dolist (symbol '(backup undo undo-all edit edit-replacement delete-and-edit ignore self-insert-command)) - (define-key map (vector 'remap symbol) 'y-or-n-p-insert-other)) + (define-key map (vector 'remap symbol) #'y-or-n-p-insert-other)) - (define-key map [remap recenter] 'minibuffer-recenter-top-bottom) - (define-key map [remap scroll-up] 'minibuffer-scroll-up-command) - (define-key map [remap scroll-down] 'minibuffer-scroll-down-command) - (define-key map [remap scroll-other-window] 'minibuffer-scroll-other-window) - (define-key map [remap scroll-other-window-down] 'minibuffer-scroll-other-window-down) + (define-key map [remap recenter] #'minibuffer-recenter-top-bottom) + (define-key map [remap scroll-up] #'minibuffer-scroll-up-command) + (define-key map [remap scroll-down] #'minibuffer-scroll-down-command) + (define-key map [remap scroll-other-window] #'minibuffer-scroll-other-window) + (define-key map [remap scroll-other-window-down] #'minibuffer-scroll-other-window-down) - (define-key map [escape] 'abort-recursive-edit) + (define-key map [escape] #'abort-recursive-edit) (dolist (symbol '(quit exit exit-prefix)) - (define-key map (vector 'remap symbol) 'abort-recursive-edit)) + (define-key map (vector 'remap symbol) #'abort-recursive-edit)) ;; FIXME: try catch-all instead of explicit bindings: - ;; (define-key map [remap t] 'y-or-n-p-insert-other) + ;; (define-key map [remap t] #'y-or-n-p-insert-other) map) "Keymap that defines additional bindings for `y-or-n-p' answers.") @@ -3381,7 +3378,7 @@ This finishes the change group by reverting all of its changes." ;; For compatibility. (define-obsolete-function-alias 'redraw-modeline - 'force-mode-line-update "24.3") + #'force-mode-line-update "24.3") (defun momentary-string-display (string pos &optional exit-char message) "Momentarily display STRING in the buffer at POS. @@ -3525,7 +3522,7 @@ When in a major mode that does not provide its own symbol at point exactly." (let ((tag (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default)))) + #'find-tag-default)))) (if tag (regexp-quote tag)))) (defun find-tag-default-as-symbol-regexp () @@ -3539,8 +3536,8 @@ symbol at point exactly." (if (and tag-regexp (eq (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default) - 'find-tag-default)) + #'find-tag-default) + #'find-tag-default)) (format "\\_<%s\\_>" tag-regexp) tag-regexp))) @@ -3874,7 +3871,7 @@ discouraged." (call-process shell-file-name infile buffer display shell-command-switch - (mapconcat 'identity (cons command args) " "))) + (mapconcat #'identity (cons command args) " "))) (defun process-file-shell-command (command &optional infile buffer display &rest args) @@ -3886,7 +3883,7 @@ Similar to `call-process-shell-command', but calls `process-file'." (with-connection-local-variables (process-file shell-file-name infile buffer display shell-command-switch - (mapconcat 'identity (cons command args) " ")))) + (mapconcat #'identity (cons command args) " ")))) (defun call-shell-region (start end command &optional delete buffer) "Send text from START to END as input to an inferior shell running COMMAND. @@ -4905,8 +4902,8 @@ FILE, a string, is described in the function `eval-after-load'." "" ;; Note: regexp-opt can't be used here, since we need to call ;; this before Emacs has been fully started. 2006-05-21 - (concat "\\(" (mapconcat 'regexp-quote load-suffixes "\\|") "\\)?")) - "\\(" (mapconcat 'regexp-quote jka-compr-load-suffixes "\\|") + (concat "\\(" (mapconcat #'regexp-quote load-suffixes "\\|") "\\)?")) + "\\(" (mapconcat #'regexp-quote jka-compr-load-suffixes "\\|") "\\)?\\'")) (defun load-history-filename-element (file-regexp) @@ -4922,7 +4919,6 @@ Return nil if there isn't one." load-elt (and loads (car loads))))) load-elt)) -(put 'eval-after-load 'lisp-indent-function 1) (defun eval-after-load (file form) "Arrange that if FILE is loaded, FORM will be run immediately afterwards. If FILE is already loaded, evaluate FORM right now. @@ -4957,7 +4953,8 @@ like `font-lock'. This function makes or adds to an entry on `after-load-alist'. See also `with-eval-after-load'." - (declare (compiler-macro + (declare (indent 1) + (compiler-macro (lambda (whole) (if (eq 'quote (car-safe form)) ;; Quote with lambda so the compiler can look inside. @@ -5064,7 +5061,7 @@ This function is called directly from the C code." "Display delayed warnings from `delayed-warnings-list'. Used from `delayed-warnings-hook' (which see)." (dolist (warning (nreverse delayed-warnings-list)) - (apply 'display-warning warning)) + (apply #'display-warning warning)) (setq delayed-warnings-list nil)) (defun collapse-delayed-warnings () @@ -5397,7 +5394,7 @@ The properties used on SYMBOL are `composefunc', `sendfunc', `abortfunc', and `hookvar'." (put symbol 'composefunc composefunc) (put symbol 'sendfunc sendfunc) - (put symbol 'abortfunc (or abortfunc 'kill-buffer)) + (put symbol 'abortfunc (or abortfunc #'kill-buffer)) (put symbol 'hookvar (or hookvar 'mail-send-hook))) @@ -5562,7 +5559,7 @@ To test whether a function can be called interactively, use (set symbol tail))))) (define-obsolete-function-alias - 'set-temporary-overlay-map 'set-transient-map "24.4") + 'set-temporary-overlay-map #'set-transient-map "24.4") (defun set-transient-map (map &optional keep-pred on-exit) "Set MAP as a temporary keymap taking precedence over other keymaps. @@ -6190,7 +6187,7 @@ returned list are in the same order as in TREE. ;; Technically, `flatten-list' is a misnomer, but we provide it here ;; for discoverability: -(defalias 'flatten-list 'flatten-tree) +(defalias 'flatten-list #'flatten-tree) ;; The initial anchoring is for better performance in searching matches. (defconst regexp-unmatchable "\\`a\\`" diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 4a01623cb88..9312fb44a1e 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -269,9 +269,7 @@ Edebug symbols (Bug#42672)." (when (memq name instrumented-names) (error "Duplicate definition of `%s'" name)) (push name instrumented-names) - (edebug-new-definition name))) - ;; Make generated symbols reproducible. - (gensym-counter 10000)) + (edebug-new-definition name)))) (eval-buffer) (should (equal (reverse instrumented-names) @@ -280,11 +278,11 @@ Edebug symbols (Bug#42672)." ;; FIXME: We'd rather have names such as ;; `cl-defgeneric/edebug/method/1 ((_ number))', but ;; that requires further changes to Edebug. - (list (intern "cl-generic-:method@10000 ((_ number))") - (intern "cl-generic-:method@10001 ((_ string))") - (intern "cl-generic-:method@10002 :around ((_ number))") + (list (intern "cl-defgeneric/edebug/method/1 (number)") + (intern "cl-defgeneric/edebug/method/1 (string)") + (intern "cl-defgeneric/edebug/method/1 :around (number)") 'cl-defgeneric/edebug/method/1 - (intern "cl-generic-:method@10003 ((_ number))") + (intern "cl-defgeneric/edebug/method/2 (number)") 'cl-defgeneric/edebug/method/2)))))) (provide 'cl-generic-tests) diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index 835d3781d09..9257f167d67 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -62,12 +62,12 @@ (defun edebug-test-code-format-vector-node (node) !start!(concat "[" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "]")) (defun edebug-test-code-format-list-node (node) !start!(concat "{" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "}")) (defun edebug-test-code-format-node (node) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index dfe2cb32065..d81376e45ec 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -951,8 +951,8 @@ primary ones (Bug#42671)." (should (equal defined-symbols - (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") - (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) + (list (intern "edebug-cl-defmethod-qualifier :around (number)") + (intern "edebug-cl-defmethod-qualifier (number)"))))))) (ert-deftest edebug-tests--conflicting-internal-names () "Check conflicts between form's head symbols and Edebug spec elements." @@ -992,23 +992,19 @@ clashes (Bug#41853)." ;; Make generated symbols reproducible. (gensym-counter 10000)) (eval-buffer) - (should (equal (reverse instrumented-names) + ;; Use `format' so as to throw away differences due to + ;; interned/uninterned symbols. + (should (equal (format "%s" (reverse instrumented-names)) ;; The outer definitions come after the inner ;; ones because their body ends later. - ;; FIXME: There are twice as many inner - ;; definitions as expected due to Bug#41988. - ;; Once that bug is fixed, remove the duplicates. ;; FIXME: We'd rather have names such as ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', ;; but that requires further changes to Edebug. - '(inner@cl-flet@10000 - inner@cl-flet@10001 - inner@cl-flet@10002 - inner@cl-flet@10003 - edebug-tests-cl-flet-1 - inner@cl-flet@10004 - inner@cl-flet@10005 - edebug-tests-cl-flet-2)))))) + (format "%s" '(inner@cl-flet@10000 + inner@cl-flet@10001 + edebug-tests-cl-flet-1 + inner@cl-flet@10002 + edebug-tests-cl-flet-2))))))) (ert-deftest edebug-tests-duplicate-symbol-backtrack () "Check that Edebug doesn't create duplicate symbols when -- cgit v1.2.3 From 623e534e49ad0a360d1291b917ce97515742a3e9 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 14 Feb 2021 22:56:08 -0500 Subject: * lisp/emacs-lisp/byte-run.el (compiler-macro): Make it Edebuggable * lisp/emacs-lisp/gv.el (gc-expander, gv-setter): Reuse the spec of `compiler-macro`. --- lisp/emacs-lisp/byte-run.el | 3 +++ lisp/emacs-lisp/gv.el | 4 +++- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 48a7fe80615..8a22388f1d7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -113,6 +113,9 @@ The return value of this function is not used." (list 'function-put (list 'quote f) ''side-effect-free (list 'quote val)))) +(put 'compiler-macro 'edebug-declaration-spec + '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body))) + (defalias 'byte-run--set-compiler-macro #'(lambda (f args compiler-function) (if (not (eq (car-safe compiler-function) 'lambda)) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 3200b1c3494..cbbed06d7c8 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -188,7 +188,9 @@ arguments as NAME. DO is a function as defined in `gv-get'." defun-declarations-alist)) ;;;###autoload -(let ((spec '(&or symbolp ("lambda" &define lambda-list def-body)))) +(let ((spec (get 'compiler-macro 'edebug-declaration-spec))) + ;; It so happens that it's the same spec for gv-* as for compiler-macros. + ;; '(&or symbolp ("lambda" &define lambda-list lambda-doc def-body)) (put 'gv-expander 'edebug-declaration-spec spec) (put 'gv-setter 'edebug-declaration-spec spec)) -- cgit v1.2.3 From 54e577fbc1fb2e1189388ac290fe70d0f87b6c76 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 14 Feb 2021 23:56:42 -0500 Subject: * lisp/emacs-lisp/edebug.el (edebug-&optional, edebug-&rest): Remove vars According to my tests, `edebug-&optional` never has any effect. And `edebug-&rest` can be replaced with a closure. (edebug-&rest-wrapper): Remove function. (edebug--match-&-spec-op): Use a closure to remember the `specs`. --- lisp/emacs-lisp/edebug.el | 59 +++++++++++++++++++---------------------------- 1 file changed, 24 insertions(+), 35 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index efca7305fea..7fae4d21d50 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1091,8 +1091,6 @@ circular objects. Let `read' read everything else." ;; This data is shared by all embedded definitions. (defvar edebug-top-window-data) -(defvar edebug-&optional) -(defvar edebug-&rest) (defvar edebug-gate nil) ;; whether no-match forces an error. (defvar edebug-def-name nil) ; name of definition, used by interactive-form @@ -1143,8 +1141,6 @@ purpose by adding an entry to this alist, and setting edebug-top-window-data edebug-def-name;; make sure it is locally nil ;; I don't like these here!! - edebug-&optional - edebug-&rest edebug-gate edebug-best-error edebug-error-point @@ -1512,6 +1508,9 @@ contains a circular object." ((consp form) ;; The first offset for a list form is for the list form itself. (if (eq 'quote (car form)) + ;; This makes sure we don't instrument 'foo + ;; which would cause the debugger to single-step + ;; the trivial evaluation of a constant. form (let* ((head (car form)) (spec (and (symbolp head) (edebug-get-spec head))) @@ -1584,10 +1583,7 @@ contains a circular object." ;; The after offset will be left in the cursor after processing the form. (let ((head (edebug-top-element-required cursor "Expected elements")) ;; Prevent backtracking whenever instrumenting. - (edebug-gate t) - ;; A list form is never optional because it matches anything. - (edebug-&optional nil) - (edebug-&rest nil)) + (edebug-gate t)) ;; Skip the first offset. (edebug-set-cursor cursor (edebug-cursor-expressions cursor) (cdr (edebug-cursor-offsets cursor))) @@ -1632,7 +1628,7 @@ contains a circular object." (setq edebug-error-point (or edebug-error-point (edebug-before-offset cursor)) edebug-best-error (or edebug-best-error args)) - (if (and edebug-gate (not edebug-&optional)) + (if edebug-gate (progn (if edebug-error-point (goto-char edebug-error-point)) @@ -1643,9 +1639,7 @@ contains a circular object." (defun edebug-match (cursor specs) ;; Top level spec matching function. ;; Used also at each lower level of specs. - (let (edebug-&optional - edebug-&rest - edebug-best-error + (let (edebug-best-error edebug-error-point (edebug-gate edebug-gate) ;; locally bound to limit effect ) @@ -1782,11 +1776,10 @@ contains a circular object." (cl-defmethod edebug--match-&-spec-op ((_ (eql &optional)) cursor specs) ;; Keep matching until one spec fails. - (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper)) + (edebug-&optional-wrapper cursor specs #'edebug-&optional-wrapper)) (defun edebug-&optional-wrapper (cursor specs remainder-handler) (let (result - (edebug-&optional specs) (edebug-gate nil) (this-form (edebug-cursor-expressions cursor)) (this-offset (edebug-cursor-offsets cursor))) @@ -1801,21 +1794,21 @@ contains a circular object." nil))) -(defun edebug-&rest-wrapper (cursor specs remainder-handler) - (if (null specs) (setq specs edebug-&rest)) - ;; Reuse the &optional handler with this as the remainder handler. - (edebug-&optional-wrapper cursor specs remainder-handler)) - (cl-defgeneric edebug--match-&-spec-op (op cursor specs) "Handle &foo spec operators. &foo spec operators operate on all the subsequent SPECS.") (cl-defmethod edebug--match-&-spec-op ((_ (eql &rest)) cursor specs) ;; Repeatedly use specs until failure. - (let ((edebug-&rest specs) ;; remember these - edebug-best-error + (let (edebug-best-error edebug-error-point) - (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper))) + ;; Reuse the &optional handler with this as the remainder handler. + (edebug-&optional-wrapper + cursor specs + (lambda (c s rh) + ;; `s' is the remaining spec to match. + ;; When it's nil, start over matching `specs'. + (edebug-&optional-wrapper c (or s specs) rh))))) (cl-defmethod edebug--match-&-spec-op ((_ (eql &or)) cursor specs) @@ -1961,19 +1954,15 @@ a sequence of elements." (defun edebug-match-sublist (cursor specs) ;; Match a sublist of specs. - (let (edebug-&optional - ;;edebug-best-error - ;;edebug-error-point - ) - (prog1 - ;; match with edebug-match-specs so edebug-best-error is not bound. - (edebug-match-specs cursor specs 'edebug-match-specs) - (if (not (edebug-empty-cursor cursor)) - (if edebug-best-error - (apply #'edebug-no-match cursor edebug-best-error) - ;; A failed &rest or &optional spec may leave some args. - (edebug-no-match cursor "Failed matching" specs) - ))))) + (prog1 + ;; match with edebug-match-specs so edebug-best-error is not bound. + (edebug-match-specs cursor specs 'edebug-match-specs) + (if (not (edebug-empty-cursor cursor)) + (if edebug-best-error + (apply #'edebug-no-match cursor edebug-best-error) + ;; A failed &rest or &optional spec may leave some args. + (edebug-no-match cursor "Failed matching" specs) + )))) (defun edebug-match-string (cursor spec) -- cgit v1.2.3 From 0bd846c17474b161b11fbe21545609cd545b1798 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 15 Feb 2021 12:44:57 +0100 Subject: Rename minor-modes to local-minor-modes * doc/lispref/modes.texi (Minor Modes): Update documentation. * lisp/simple.el (completion-with-modes-p): Change usage. * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Change usage. * src/buffer.c: Rename from minor_modes to local_minor_modes throughout. (syms_of_buffer): Rename minor-modes to local-minor-modes. * src/buffer.h (struct buffer): Rename minor_modes_. * src/pdumper.c (dump_buffer): Update hash and usage. --- doc/lispref/modes.texi | 2 +- etc/NEWS | 2 +- lisp/emacs-lisp/easy-mmode.el | 6 +++--- lisp/simple.el | 7 ++++--- src/buffer.c | 13 +++++++------ src/buffer.h | 2 +- src/pdumper.c | 4 ++-- 7 files changed, 19 insertions(+), 17 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index b06cb585069..192ffb6a0a9 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1461,7 +1461,7 @@ used only with Diff mode. other minor modes in effect. It should be possible to activate and deactivate minor modes in any order. -@defvar minor-modes +@defvar local-minor-modes This buffer-local variable lists the currently enabled minor modes in the current buffer, and is a list of symbols. @end defvar diff --git a/etc/NEWS b/etc/NEWS index 1adfb8c5bb1..eeaed3b5cfa 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2295,7 +2295,7 @@ minor mode activated. Note that using this form will create byte code that is not compatible with byte code in previous Emacs versions. +++ -** New buffer-local variable 'minor-modes'. +** New buffer-local variable 'local-minor-modes'. This permanently buffer-local variable holds a list of currently enabled minor modes in the current buffer (as a list of symbols). diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 5ba0d2187f2..c48ec505ce0 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -331,10 +331,10 @@ or call the function `%s'.")))) (t t))) (unless ,globalp - ;; Keep `minor-modes' up to date. - (setq minor-modes (delq ',modefun minor-modes)) + ;; Keep `local-minor-modes' up to date. + (setq local-minor-modes (delq ',modefun local-minor-modes)) (when ,getter - (push ',modefun minor-modes))) + (push ',modefun local-minor-modes))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) diff --git a/lisp/simple.el b/lisp/simple.el index 8d27cf8d625..cb7496d37c5 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1984,13 +1984,14 @@ BUFFER, or any of the active minor modes in BUFFER." (if (null (cdr modes)) (or (provided-mode-derived-p (buffer-local-value 'major-mode buffer) (car modes)) - (memq (car modes) (buffer-local-value 'minor-modes buffer))) + (memq (car modes) + (buffer-local-value 'local-minor-modes buffer))) ;; Uncommon case: Multiple modes. (apply #'provided-mode-derived-p (buffer-local-value 'major-mode buffer) modes) (seq-intersection modes - (buffer-local-value 'minor-modes buffer) + (buffer-local-value 'local-minor-modes buffer) #'eq))))) (defun completion-with-modes-p (modes buffer) @@ -2002,7 +2003,7 @@ or (if one of MODES is a minor mode), if it is switched on in BUFFER." modes) ;; It's a minor mode. (seq-intersection modes - (buffer-local-value 'minor-modes buffer) + (buffer-local-value 'local-minor-modes buffer) #'eq))) (defun completion-button-p (category buffer) diff --git a/src/buffer.c b/src/buffer.c index 487599dbbed..5bd9b37702f 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -292,9 +292,9 @@ bset_major_mode (struct buffer *b, Lisp_Object val) b->major_mode_ = val; } static void -bset_minor_modes (struct buffer *b, Lisp_Object val) +bset_local_minor_modes (struct buffer *b, Lisp_Object val) { - b->minor_modes_ = val; + b->local_minor_modes_ = val; } static void bset_mark (struct buffer *b, Lisp_Object val) @@ -898,7 +898,7 @@ CLONE nil means the indirect buffer's state is reset to default values. */) bset_file_truename (b, Qnil); bset_display_count (b, make_fixnum (0)); bset_backed_up (b, Qnil); - bset_minor_modes (b, Qnil); + bset_local_minor_modes (b, Qnil); bset_auto_save_file_name (b, Qnil); set_buffer_internal_1 (b); Fset (intern ("buffer-save-without-query"), Qnil); @@ -973,7 +973,7 @@ reset_buffer (register struct buffer *b) b->clip_changed = 0; b->prevent_redisplay_optimizations_p = 1; bset_backed_up (b, Qnil); - bset_minor_modes (b, Qnil); + bset_local_minor_modes (b, Qnil); BUF_AUTOSAVE_MODIFF (b) = 0; b->auto_save_failure_time = 0; bset_auto_save_file_name (b, Qnil); @@ -5158,7 +5158,7 @@ init_buffer_once (void) bset_auto_save_file_name (&buffer_local_flags, make_fixnum (-1)); bset_read_only (&buffer_local_flags, make_fixnum (-1)); bset_major_mode (&buffer_local_flags, make_fixnum (-1)); - bset_minor_modes (&buffer_local_flags, make_fixnum (-1)); + bset_local_minor_modes (&buffer_local_flags, make_fixnum (-1)); bset_mode_name (&buffer_local_flags, make_fixnum (-1)); bset_undo_list (&buffer_local_flags, make_fixnum (-1)); bset_mark_active (&buffer_local_flags, make_fixnum (-1)); @@ -5625,7 +5625,8 @@ The default value (normally `fundamental-mode') affects new buffers. A value of nil means to use the current buffer's major mode, provided it is not marked as "special". */); - DEFVAR_PER_BUFFER ("minor-modes", &BVAR (current_buffer, minor_modes), + DEFVAR_PER_BUFFER ("local-minor-modes", + &BVAR (current_buffer, local_minor_modes), Qnil, doc: /* Minor modes currently active in the current buffer. This is a list of symbols, or nil if there are no minor modes active. */); diff --git a/src/buffer.h b/src/buffer.h index 0668d16608b..24e9c3fcbc8 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -339,7 +339,7 @@ struct buffer Lisp_Object major_mode_; /* Symbol listing all currently enabled minor modes. */ - Lisp_Object minor_modes_; + Lisp_Object local_minor_modes_; /* Pretty name of major mode (e.g., "Lisp"). */ Lisp_Object mode_name_; diff --git a/src/pdumper.c b/src/pdumper.c index b68f992c33a..337742fda4a 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2692,7 +2692,7 @@ dump_hash_table (struct dump_context *ctx, static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_732A01EB61 +#if CHECK_STRUCTS && !defined HASH_buffer_F8FE65D42F # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -2703,7 +2703,7 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) buffer->window_count = 0; else eassert (buffer->window_count == -1); - buffer->minor_modes_ = Qnil; + buffer->local_minor_modes_ = Qnil; buffer->last_selected_window_ = Qnil; buffer->display_count_ = make_fixnum (0); buffer->clip_changed = 0; -- cgit v1.2.3 From b535c8ba8735409b43ec9b1ce99a966cfa1383b1 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 15 Feb 2021 13:08:15 +0100 Subject: Add a new variable `global-minor-modes' * doc/lispref/modes.texi (Minor Modes): Document it. * lisp/simple.el (global-minor-modes): New variable. (completion-in-mode-p): Use it. (completion-with-modes-p): Use it. * lisp/emacs-lisp/easy-mmode.el (define-minor-mode): Support it. --- doc/lispref/modes.texi | 5 +++++ etc/NEWS | 8 +++++++- lisp/emacs-lisp/easy-mmode.el | 13 ++++++++----- lisp/simple.el | 13 ++++++++++--- 4 files changed, 30 insertions(+), 9 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index 192ffb6a0a9..e1299b52d41 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -1466,6 +1466,11 @@ This buffer-local variable lists the currently enabled minor modes in the current buffer, and is a list of symbols. @end defvar +@defvar global-minor-modes +This variable lists the currently enabled global minor modes, and is a +list of symbols. +@end defvar + @defvar minor-mode-list The value of this variable is a list of all minor mode commands. @end defvar diff --git a/etc/NEWS b/etc/NEWS index eeaed3b5cfa..7f32f7bf6a9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2297,7 +2297,13 @@ that is not compatible with byte code in previous Emacs versions. +++ ** New buffer-local variable 'local-minor-modes'. This permanently buffer-local variable holds a list of currently -enabled minor modes in the current buffer (as a list of symbols). +enabled non-global minor modes in the current buffer (as a list of +symbols). + ++++ +** New variable 'global-minor-modes'. +This variable holds a list of currently enabled global minor modes (as +a list of symbols). +++ ** 'define-minor-mode' now takes an :interactive argument. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index c48ec505ce0..4a9e58083b0 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -330,11 +330,14 @@ or call the function `%s'.")))) nil) (t t))) - (unless ,globalp - ;; Keep `local-minor-modes' up to date. - (setq local-minor-modes (delq ',modefun local-minor-modes)) - (when ,getter - (push ',modefun local-minor-modes))) + ;; Keep minor modes list up to date. + ,@(if globalp + `((setq global-minor-modes (delq ',modefun global-minor-modes)) + (when ,getter + (push ',modefun global-minor-modes))) + `((setq local-minor-modes (delq ',modefun local-minor-modes)) + (when ,getter + (push ',modefun local-minor-modes)))) ,@body ;; The on/off hooks are here for backward compatibility only. (run-hooks ',hook (if ,getter ',hook-on ',hook-off)) diff --git a/lisp/simple.el b/lisp/simple.el index cb7496d37c5..aafbb3e1f88 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -138,6 +138,10 @@ messages are highlighted; this helps to see what messages were visited." nil "Overlay highlighting the current error message in the `next-error' buffer.") +(defvar global-minor-modes nil + "A list of the currently enabled global minor modes. +This is a list of symbols.") + (defcustom next-error-hook nil "List of hook functions run by `next-error' after visiting source file." :type 'hook @@ -1985,14 +1989,16 @@ BUFFER, or any of the active minor modes in BUFFER." (or (provided-mode-derived-p (buffer-local-value 'major-mode buffer) (car modes)) (memq (car modes) - (buffer-local-value 'local-minor-modes buffer))) + (buffer-local-value 'local-minor-modes buffer)) + (memq (car modes) global-minor-modes)) ;; Uncommon case: Multiple modes. (apply #'provided-mode-derived-p (buffer-local-value 'major-mode buffer) modes) (seq-intersection modes (buffer-local-value 'local-minor-modes buffer) - #'eq))))) + #'eq) + (seq-intersection modes global-minor-modes #'eq))))) (defun completion-with-modes-p (modes buffer) "Say whether MODES are in action in BUFFER. @@ -2004,7 +2010,8 @@ or (if one of MODES is a minor mode), if it is switched on in BUFFER." ;; It's a minor mode. (seq-intersection modes (buffer-local-value 'local-minor-modes buffer) - #'eq))) + #'eq) + (seq-intersection modes global-minor-modes #'eq))) (defun completion-button-p (category buffer) "Return non-nil if there's a button of CATEGORY at point in BUFFER." -- cgit v1.2.3 From fc4927fc3a27e995337612dde8614f0309616dde Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 15 Feb 2021 10:50:07 -0500 Subject: * lisp/emacs-lisp/bindat.el: Expose the `struct` variable (bug#46534) (bindat--unpack-group, bindat--length-group, bindat--pack-group): Mark it as dynamically scoped. --- lisp/emacs-lisp/bindat.el | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 0d9ba57d663..bf01347ae0e 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -26,7 +26,7 @@ ;; Packing and unpacking of (binary) data structures. ;; ;; The data formats used in binary files and network protocols are -;; often structed data which can be described by a C-style structure +;; often structured data which can be described by a C-style structure ;; such as the one shown below. Using the bindat package, decoding ;; and encoding binary data formats like these is made simple using a ;; structure specification which closely resembles the C style @@ -135,7 +135,8 @@ ;; | ( [FIELD] repeat COUNT ITEM... ) ;; -- In (eval EXPR), the value of the last field is available in -;; the dynamically bound variable `last'. +;; the dynamically bound variable `last' and all the previous +;; ones in the variable `struct'. ;; TYPE ::= ( eval EXPR ) -- interpret result as TYPE ;; | u8 | byte -- length 1 @@ -191,7 +192,7 @@ ;;; Code: ;; Helper functions for structure unpacking. -;; Relies on dynamic binding of BINDAT-RAW and BINDAT-IDX +;; Relies on dynamic binding of `bindat-raw' and `bindat-idx'. (defvar bindat-raw) (defvar bindat-idx) @@ -276,8 +277,8 @@ (t nil))) (defun bindat--unpack-group (spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) (let (struct last) (while spec (let* ((item (car spec)) @@ -378,9 +379,9 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (ip . 4))) (defun bindat--length-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) (while spec (let* ((item (car spec)) (field (car item)) @@ -544,9 +545,9 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) - (with-suppressed-warnings ((lexical last)) - (defvar last)) - (let (last) + (with-suppressed-warnings ((lexical struct last)) + (defvar struct) (defvar last)) + (let ((struct struct) last) (while spec (let* ((item (car spec)) (field (car item)) -- cgit v1.2.3 From d41a4ad4ae6f25c3cbc90aaaa33781821bb655c5 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 15 Feb 2021 12:07:52 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp--expand-all): Warn on empty let bodies --- lisp/emacs-lisp/macroexp.el | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 13ff5ef2eda..0934e43e66a 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -299,7 +299,12 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) + (if (null body) + (macroexp-unprogn + (macroexp--warn-and-return + (format "Empty %s body" fun) + nil t)) + (macroexp--all-forms body)) (cdr form)) form)) (`(,(and fun `(lambda . ,_)) . ,args) -- cgit v1.2.3 From 83d9fbe3bb8ffdf9e4719842e2510a8dbde86f78 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 15 Feb 2021 21:25:15 -0500 Subject: * lisp/emacs-lisp/bindat.el (bindat-spec): New macro. It's basically an alias for `quote`, but it offers the advantage of providing Edebug support and opens the possibility of compiling the bindat spec to ELisp code. * doc/lispref/processes.texi (Bindat Spec): Document `bindat-spec`. (Bindat Functions): Tweak a few things to adjust to the state of the code. * test/lisp/emacs-lisp/bindat-tests.el: Use it. * test/lisp/emacs-lisp/edebug-tests.el (edebug-tests--read): New function. (edebug-tests--&rest-behavior): New test. --- doc/lispref/processes.texi | 28 +++++++++-------- etc/NEWS | 2 ++ lisp/emacs-lisp/bindat.el | 59 ++++++++++++++++++++++++++++++------ test/lisp/emacs-lisp/bindat-tests.el | 9 ++++-- test/lisp/emacs-lisp/edebug-tests.el | 17 +++++++++++ 5 files changed, 91 insertions(+), 24 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 83461656063..661e56d2762 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3368,6 +3368,11 @@ processed, and how to pack or unpack it. We normally keep bindat specs in variables whose names end in @samp{-bindat-spec}; that kind of name is automatically recognized as risky. +@defmac bindat-spec &rest specs +Creates a Bindat spec object according to the data layout +specification @var{specs}. +@end defmac + @cindex endianness @cindex big endian @cindex little endian @@ -3398,7 +3403,6 @@ Unsigned integer in network byte order, with length 3. @itemx dword @itemx long Unsigned integer in network byte order, with length 4. -Note: These values may be limited by Emacs's integer implementation limits. @item u16r @itemx u24r @@ -3534,16 +3538,16 @@ repetition has completed. @node Bindat Functions @subsection Functions to Unpack and Pack Bytes - In the following documentation, @var{spec} refers to a data layout -specification, @code{bindat-raw} to a byte array, and @var{struct} to an -alist representing unpacked field data. + In the following documentation, @var{spec} refers to a Bindat spec +object as returned from @code{bindat-spec}, @code{raw} to a byte +array, and @var{struct} to an alist representing unpacked field data. -@defun bindat-unpack spec bindat-raw &optional bindat-idx +@defun bindat-unpack spec raw &optional idx @c FIXME? Again, no multibyte? This function unpacks data from the unibyte string or byte -array @code{bindat-raw} +array var{raw} according to @var{spec}. Normally, this starts unpacking at the -beginning of the byte array, but if @var{bindat-idx} is non-@code{nil}, it +beginning of the byte array, but if @var{idx} is non-@code{nil}, it specifies a zero-based starting position to use instead. The value is an alist or nested alist in which each element describes @@ -3576,15 +3580,15 @@ This function returns the total length of the data in @var{struct}, according to @var{spec}. @end defun -@defun bindat-pack spec struct &optional bindat-raw bindat-idx +@defun bindat-pack spec struct &optional raw idx This function returns a byte array packed according to @var{spec} from the data in the alist @var{struct}. It normally creates and fills a -new byte array starting at the beginning. However, if @var{bindat-raw} +new byte array starting at the beginning. However, if @var{raw} is non-@code{nil}, it specifies a pre-allocated unibyte string or vector to -pack into. If @var{bindat-idx} is non-@code{nil}, it specifies the starting -offset for packing into @code{bindat-raw}. +pack into. If @var{idx} is non-@code{nil}, it specifies the starting +offset for packing into var{raw}. -When pre-allocating, you should make sure @code{(length @var{bindat-raw})} +When pre-allocating, you should make sure @code{(length @var{raw})} meets or exceeds the total length to avoid an out-of-range error. @end defun diff --git a/etc/NEWS b/etc/NEWS index 7f32f7bf6a9..3ac9bb21bd8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -357,6 +357,8 @@ the buffer cycles the whole buffer between "only top-level headings", It used to be enabled when Emacs is started in GUI mode but not when started in text mode. The cursor still only actually blinks in GUI frames. ++++ +** Bindat has a new 'bindat-spec' macro to define specs, with Edebug support ** pcase +++ diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index bf01347ae0e..0bb4b870704 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -65,13 +65,15 @@ ;; The corresponding Lisp bindat specification looks like this: ;; ;; (setq header-bindat-spec -;; '((dest-ip ip) +;; (bindat-spec +;; (dest-ip ip) ;; (src-ip ip) ;; (dest-port u16) ;; (src-port u16))) ;; ;; (setq data-bindat-spec -;; '((type u8) +;; (bindat-spec +;; (type u8) ;; (opcode u8) ;; (length u16r) ;; little endian order ;; (id strz 8) @@ -79,7 +81,8 @@ ;; (align 4))) ;; ;; (setq packet-bindat-spec -;; '((header struct header-bindat-spec) +;; (bindat-spec +;; (header struct header-bindat-spec) ;; (items u8) ;; (fill 3) ;; (item repeat (items) @@ -179,7 +182,7 @@ ;; is interpreted by evalling TAG_VAL and then comparing that to ;; each TAG using equal; if a match is found, the corresponding SPEC ;; is used. -;; If TAG is a form (eval EXPR), EXPR is evalled with `tag' bound to the +;; If TAG is a form (eval EXPR), EXPR is eval'ed with `tag' bound to the ;; value of TAG_VAL; the corresponding SPEC is used if the result is non-nil. ;; Finally, if TAG is t, the corresponding SPEC is used unconditionally. ;; @@ -368,8 +371,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq field (cdr field))) struct) - -;; Calculate bindat-raw length of structured data +;;;; Calculate bindat-raw length of structured data (defvar bindat--fixed-length-alist '((u8 . 1) (byte . 1) @@ -452,13 +454,13 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bindat-idx (+ bindat-idx len)))))))) (defun bindat-length (spec struct) - "Calculate bindat-raw length for STRUCT according to bindat SPEC." + "Calculate `bindat-raw' length for STRUCT according to bindat SPEC." (let ((bindat-idx 0)) (bindat--length-group struct spec) bindat-idx)) -;; Pack structured data into bindat-raw +;;;; Pack structured data into bindat-raw (defun bindat--pack-u8 (v) (aset bindat-raw bindat-idx (logand v 255)) @@ -623,8 +625,47 @@ Optional fourth arg IDX is the starting offset into RAW." (bindat--pack-group struct spec) (if raw nil bindat-raw))) +;;;; Debugging support + +(def-edebug-elem-spec 'bindat-spec '(&rest bindat-item)) + +(def-edebug-elem-spec 'bindat-item + '(([&optional bindat-field] + &or ["eval" form] + ["fill" bindat-len] + ["align" bindat-len] + ["struct" form] ;A reference to another bindat-spec. + ["union" bindat-tag-val &rest (bindat-tag bindat-spec)] + ["repeat" integerp bindat-spec] + bindat-type))) + +(def-edebug-elem-spec 'bindat-type + '(&or ("eval" form) + ["str" bindat-len] + ["strz" bindat-len] + ["vec" bindat-len &optional bindat-type] + ["bits" bindat-len] + symbolp)) + +(def-edebug-elem-spec 'bindat-field + '(&or ("eval" form) symbolp)) + +(def-edebug-elem-spec 'bindat-len '(&or [] "nil" bindat-arg)) + +(def-edebug-elem-spec 'bindat-tag-val '(bindat-arg)) + +(def-edebug-elem-spec 'bindat-tag '(&or ("eval" form) atom)) + +(def-edebug-elem-spec 'bindat-arg + '(&or ("eval" form) integerp (&rest symbolp integerp))) + +(defmacro bindat-spec (&rest fields) + "Build the bindat spec described by FIELDS." + (declare (indent 0) (debug (bindat-spec))) + ;; FIXME: We should really "compile" this to a triplet of functions! + `',fields) -;; Misc. format conversions +;;;; Misc. format conversions (defun bindat-format-vector (vect fmt sep &optional len) "Format vector VECT using element format FMT and separator SEP. diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index a9a881987c0..72883fc2ec7 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -24,13 +24,15 @@ (require 'cl-lib) (defvar header-bindat-spec - '((dest-ip ip) + (bindat-spec + (dest-ip ip) (src-ip ip) (dest-port u16) (src-port u16))) (defvar data-bindat-spec - '((type u8) + (bindat-spec + (type u8) (opcode u8) (length u16r) ;; little endian order (id strz 8) @@ -38,7 +40,8 @@ (align 4))) (defvar packet-bindat-spec - '((header struct header-bindat-spec) + (bindat-spec + (header struct header-bindat-spec) (items u8) (fill 3) (item repeat (items) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index d81376e45ec..daac43372ac 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -970,6 +970,23 @@ primary ones (Bug#42671)." (eval '(setf (edebug-test-code-use-gv-expander (cons 'a 'b)) 3) t)) "(func")))) +(defun edebug-tests--read (form spec) + (with-temp-buffer + (print form (current-buffer)) + (goto-char (point-min)) + (cl-letf ((edebug-all-forms t) + ((get (car form) 'edebug-form-spec) spec)) + (edebug--read nil (current-buffer))))) + +(ert-deftest edebug-tests--&rest-behavior () + ;; `&rest' is documented to allow the last "repetition" to be aborted early. + (should (edebug-tests--read '(dummy x 1 y 2 z) + '(&rest symbolp integerp))) + ;; `&rest' should notice here that the "symbolp integerp" sequence + ;; is not respected. + (should-error (edebug-tests--read '(dummy x 1 2 y) + '(&rest symbolp integerp)))) + (ert-deftest edebug-tests-cl-flet () "Check that Edebug can instrument `cl-flet' forms without name clashes (Bug#41853)." -- cgit v1.2.3 From a0b35e2f80df98a3789286af8f68e85fddf368db Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 15 Feb 2021 23:22:09 -0500 Subject: * lisp/emacs-lisp/bindat.el: Clarify when field labels are optional The fixes the doc and the Edebug spec, as well as a subtle issue in the code where a field whose name is (eval 'fill) was mistakenly considered as an anonymous field of type `fill`. (bindat--unpack-item, bindat--unpack-group, bindat--length-group) (bindat--pack-item, bindat--pack-group): Use dotimes, dolist, and pcase. (bindat--item-aux): New edebug elem. (bindat-item): Use it to fix the handling of optional fields. (bindat-format-vector): Use `mapconcat`. --- lisp/emacs-lisp/bindat.el | 217 ++++++++++++++++++++++------------------------ 1 file changed, 102 insertions(+), 115 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 0bb4b870704..eafcdc77606 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -129,13 +129,13 @@ ;; SPEC ::= ( ITEM... ) -;; ITEM ::= ( [FIELD] TYPE ) +;; ITEM ::= ( FIELD TYPE ) ;; | ( [FIELD] eval FORM ) -- eval FORM for side-effect only ;; | ( [FIELD] fill LEN ) -- skip LEN bytes ;; | ( [FIELD] align LEN ) -- skip to next multiple of LEN bytes ;; | ( [FIELD] struct SPEC_NAME ) ;; | ( [FIELD] union TAG_VAL (TAG SPEC)... [(t SPEC)] ) -;; | ( [FIELD] repeat COUNT ITEM... ) +;; | ( FIELD repeat ARG ITEM... ) ;; -- In (eval EXPR), the value of the last field is available in ;; the dynamically bound variable `last' and all the previous @@ -151,7 +151,7 @@ ;; | strz LEN -- LEN byte (zero-terminated) string ;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) ;; | ip -- 4 byte vector -;; | bits LEN -- List with bits set in LEN bytes. +;; | bits LEN -- bit vector using LEN bytes. ;; ;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) ;; and 0x1c 0x28 to (3 5 10 11 12). @@ -226,22 +226,22 @@ (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((memq type '(u8 byte)) + (pcase type + ((or 'u8 'byte) (bindat--unpack-u8)) - ((memq type '(u16 word short)) + ((or 'u16 'word 'short) (bindat--unpack-u16)) - ((eq type 'u24) + ('u24 (bindat--unpack-u24)) - ((memq type '(u32 dword long)) + ((or 'u32 'dword 'long) (bindat--unpack-u32)) - ((eq type 'u16r) + ('u16r (bindat--unpack-u16r)) - ((eq type 'u24r) + ('u24r (bindat--unpack-u24r)) - ((eq type 'u32r) + ('u32r (bindat--unpack-u32r)) - ((eq type 'bits) + ('bits (let ((bits nil) (bnum (1- (* 8 len))) j m) (while (>= bnum 0) (if (= (setq m (bindat--unpack-u8)) 0) @@ -253,12 +253,12 @@ (setq bnum (1- bnum) j (ash j -1))))) bits)) - ((eq type 'str) + ('str (let ((s (substring bindat-raw bindat-idx (+ bindat-idx len)))) (setq bindat-idx (+ bindat-idx len)) (if (stringp s) s (apply #'unibyte-string s)))) - ((eq type 'strz) + ('strz (let ((i 0) s) (while (and (< i len) (/= (aref bindat-raw (+ bindat-idx i)) 0)) (setq i (1+ i))) @@ -266,34 +266,29 @@ (setq bindat-idx (+ bindat-idx len)) (if (stringp s) s (apply #'unibyte-string s)))) - ((eq type 'vec) - (let ((v (make-vector len 0)) (i 0) (vlen 1)) + ('vec + (let ((v (make-vector len 0)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) - (while (< i len) - (aset v i (bindat--unpack-item type vlen vectype)) - (setq i (1+ i))) + (dotimes (i len) + (aset v i (bindat--unpack-item type vlen vectype))) v)) - (t nil))) + (_ nil))) (defun bindat--unpack-group (spec) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let (struct last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3) data) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -303,29 +298,29 @@ len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq data (eval len t)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) + ('align (while (/= (% bindat-idx len) 0) (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('struct (setq data (bindat--unpack-group (eval len t)))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (push (bindat--unpack-group (nthcdr tail item)) data) - (setq index (1+ index))) - (setq data (nreverse data)))) - ((eq type 'union) + ('repeat + (dotimes (_ len) + (push (bindat--unpack-group (nthcdr tail item)) data)) + (setq data (nreverse data))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -337,7 +332,8 @@ (and (consp cc) (eval cc t))) (setq data (bindat--unpack-group (cdr case)) cases nil))))) - (t + ((pred integerp) (debug t)) + (_ (setq data (bindat--unpack-item type len vectype) last data))) (if data @@ -384,16 +380,12 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let ((struct struct) last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -403,6 +395,8 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) @@ -413,27 +407,25 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." type (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil))) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) + ('align (while (/= (% bindat-idx len) 0) (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('struct (bindat--length-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--length-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + ('repeat + (dotimes (index len) + (bindat--length-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -446,7 +438,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (progn (bindat--length-group struct (cdr case)) (setq cases nil)))))) - (t + (_ (if (setq type (assq type bindat--fixed-length-alist)) (setq len (* len (cdr type)))) (if field @@ -495,24 +487,24 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) - (cond - ((null v) + (pcase type + ((guard (null v)) (setq bindat-idx (+ bindat-idx len))) - ((memq type '(u8 byte)) + ((or 'u8 'byte) (bindat--pack-u8 v)) - ((memq type '(u16 word short)) + ((or 'u16 'word 'short) (bindat--pack-u16 v)) - ((eq type 'u24) + ('u24 (bindat--pack-u24 v)) - ((memq type '(u32 dword long)) + ((or 'u32 'dword 'long) (bindat--pack-u32 v)) - ((eq type 'u16r) + ('u16r (bindat--pack-u16r v)) - ((eq type 'u24r) + ('u24r (bindat--pack-u24r v)) - ((eq type 'u32r) + ('u32r (bindat--pack-u32r v)) - ((eq type 'bits) + ('bits (let ((bnum (1- (* 8 len))) j m) (while (>= bnum 0) (setq m 0) @@ -525,41 +517,35 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bnum (1- bnum) j (ash j -1)))) (bindat--pack-u8 m)))) - ((memq type '(str strz)) - (let ((l (length v)) (i 0)) + ((or 'str 'strz) + (let ((l (length v))) (if (> l len) (setq l len)) - (while (< i l) - (aset bindat-raw (+ bindat-idx i) (aref v i)) - (setq i (1+ i))) + (dotimes (i l) + (aset bindat-raw (+ bindat-idx i) (aref v i))) (setq bindat-idx (+ bindat-idx len)))) - ((eq type 'vec) - (let ((l (length v)) (i 0) (vlen 1)) + ('vec + (let ((l (length v)) (vlen 1)) (if (consp vectype) (setq vlen (nth 1 vectype) vectype (nth 2 vectype)) (setq type (or vectype 'u8) vectype nil)) (if (> l len) (setq l len)) - (while (< i l) - (bindat--pack-item (aref v i) type vlen vectype) - (setq i (1+ i))))) - (t + (dotimes (i l) + (bindat--pack-item (aref v i) type vlen vectype)))) + (_ (setq bindat-idx (+ bindat-idx len))))) (defun bindat--pack-group (struct spec) (with-suppressed-warnings ((lexical struct last)) (defvar struct) (defvar last)) (let ((struct struct) last) - (while spec - (let* ((item (car spec)) - (field (car item)) + (dolist (item spec) + (let* ((field (car item)) (type (nth 1 item)) (len (nth 2 item)) (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) - (setq spec (cdr spec)) - (if (and (consp field) (eq (car field) 'eval)) - (setq field (eval (car (cdr field)) t))) (if (and type (consp type) (eq (car type) 'eval)) (setq type (eval (car (cdr type)) t))) (if (and len (consp len) (eq (car len) 'eval)) @@ -569,31 +555,31 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." len type type field field nil)) + (if (and (consp field) (eq (car field) 'eval)) + (setq field (eval (car (cdr field)) t))) (if (and (consp len) (not (eq type 'eval))) (setq len (apply #'bindat-get-field struct len))) (if (not len) (setq len 1)) - (cond - ((eq type 'eval) + (pcase type + ('eval (if field (setq struct (cons (cons field (eval len t)) struct)) (eval len t))) - ((eq type 'fill) + ('fill (setq bindat-idx (+ bindat-idx len))) - ((eq type 'align) + ('align (while (/= (% bindat-idx len) 0) (setq bindat-idx (1+ bindat-idx)))) - ((eq type 'struct) + ('struct (bindat--pack-group (if field (bindat-get-field struct field) struct) (eval len t))) - ((eq type 'repeat) - (let ((index 0) (count len)) - (while (< index count) - (bindat--pack-group - (nth index (bindat-get-field struct field)) - (nthcdr tail item)) - (setq index (1+ index))))) - ((eq type 'union) + ('repeat + (dotimes (index len) + (bindat--pack-group + (nth index (bindat-get-field struct field)) + (nthcdr tail item)))) + ('union (with-suppressed-warnings ((lexical tag)) (defvar tag)) (let ((tag len) (cases (nthcdr tail item)) case cc) @@ -606,7 +592,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (progn (bindat--pack-group struct (cdr case)) (setq cases nil)))))) - (t + (_ (setq last (bindat-get-field struct field)) (bindat--pack-item last type len vectype) )))))) @@ -629,15 +615,21 @@ Optional fourth arg IDX is the starting offset into RAW." (def-edebug-elem-spec 'bindat-spec '(&rest bindat-item)) + +(def-edebug-elem-spec 'bindat--item-aux + ;; Field types which can come without a field label. + '(&or ["eval" form] + ["fill" bindat-len] + ["align" bindat-len] + ["struct" form] ;A reference to another bindat-spec. + ["union" bindat-tag-val &rest (bindat-tag bindat-spec)])) + (def-edebug-elem-spec 'bindat-item - '(([&optional bindat-field] - &or ["eval" form] - ["fill" bindat-len] - ["align" bindat-len] - ["struct" form] ;A reference to another bindat-spec. - ["union" bindat-tag-val &rest (bindat-tag bindat-spec)] - ["repeat" integerp bindat-spec] - bindat-type))) + '((&or bindat--item-aux ;Without label.. + [bindat-field ;..or with label + &or bindat--item-aux + ["repeat" bindat-arg bindat-spec] + bindat-type]))) (def-edebug-elem-spec 'bindat-type '(&or ("eval" form) @@ -672,13 +664,8 @@ Optional fourth arg IDX is the starting offset into RAW." Result is a string with each element of VECT formatted using FMT and separated by the string SEP. If optional fourth arg LEN is given, use only that many elements from VECT." - (unless len - (setq len (length vect))) - (let ((i len) (fmt2 (concat sep fmt)) (s nil)) - (while (> i 0) - (setq i (1- i) - s (cons (format (if (= i 0) fmt fmt2) (aref vect i)) s))) - (apply #'concat s))) + (when len (setq vect (substring vect 0 len))) + (mapconcat (lambda (x) (format fmt x)) vect sep)) (defun bindat-vector-to-dec (vect &optional sep) "Format vector VECT in decimal format separated by dots. -- cgit v1.2.3 From 62cda6acd61f6de2698674391a26ce0a8672fc93 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 15 Feb 2021 23:54:45 -0500 Subject: * lisp/emacs-lisp/bindat.el: Add 64bit int support (bindat--unpack-u64, bindat--unpack-u64r, bindat--pack-u64) (bindat--pack-u64r): New functions. (bindat--unpack-item, bindat--pack-item): Use them. (bindat--fixed-length-alist): Add new types. --- doc/lispref/processes.texi | 11 +++++++--- etc/NEWS | 5 ++++- lisp/emacs-lisp/bindat.el | 51 ++++++++++++++++++++++++++++------------------ 3 files changed, 43 insertions(+), 24 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 661e56d2762..bb4c57a6196 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -3404,10 +3404,15 @@ Unsigned integer in network byte order, with length 3. @itemx long Unsigned integer in network byte order, with length 4. +@item u64 +Unsigned integer in network byte order, with length 8. + @item u16r @itemx u24r @itemx u32r -Unsigned integer in little endian order, with length 2, 3 and 4, respectively. +@itemx u64r +Unsigned integer in little endian order, with length 2, 3, 4, and +8, respectively. @item str @var{len} String of length @var{len}. @@ -3545,7 +3550,7 @@ array, and @var{struct} to an alist representing unpacked field data. @defun bindat-unpack spec raw &optional idx @c FIXME? Again, no multibyte? This function unpacks data from the unibyte string or byte -array var{raw} +array @var{raw} according to @var{spec}. Normally, this starts unpacking at the beginning of the byte array, but if @var{idx} is non-@code{nil}, it specifies a zero-based starting position to use instead. @@ -3586,7 +3591,7 @@ the data in the alist @var{struct}. It normally creates and fills a new byte array starting at the beginning. However, if @var{raw} is non-@code{nil}, it specifies a pre-allocated unibyte string or vector to pack into. If @var{idx} is non-@code{nil}, it specifies the starting -offset for packing into var{raw}. +offset for packing into @var{raw}. When pre-allocating, you should make sure @code{(length @var{raw})} meets or exceeds the total length to avoid an out-of-range error. diff --git a/etc/NEWS b/etc/NEWS index 3ac9bb21bd8..943ad6ac591 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -357,8 +357,11 @@ the buffer cycles the whole buffer between "only top-level headings", It used to be enabled when Emacs is started in GUI mode but not when started in text mode. The cursor still only actually blinks in GUI frames. +** Bindat +++ -** Bindat has a new 'bindat-spec' macro to define specs, with Edebug support +*** New types 'u64' and 'u64r' ++++ +*** New macro 'bindat-spec' to define specs, with Edebug support ** pcase +++ diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index eafcdc77606..1f5022c2743 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -146,7 +146,8 @@ ;; | u16 | word | short -- length 2, network byte order ;; | u24 -- 3-byte value ;; | u32 | dword | long -- length 4, network byte order -;; | u16r | u24r | u32r -- little endian byte order. +;; | u64 -- length 8, network byte order +;; | u16r | u24r | u32r | u64r - little endian byte order. ;; | str LEN -- LEN byte string ;; | strz LEN -- LEN byte (zero-terminated) string ;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) @@ -214,6 +215,9 @@ (defun bindat--unpack-u32 () (logior (ash (bindat--unpack-u16) 16) (bindat--unpack-u16))) +(defun bindat--unpack-u64 () + (logior (ash (bindat--unpack-u32) 32) (bindat--unpack-u32))) + (defun bindat--unpack-u16r () (logior (bindat--unpack-u8) (ash (bindat--unpack-u8) 8))) @@ -223,6 +227,9 @@ (defun bindat--unpack-u32r () (logior (bindat--unpack-u16r) (ash (bindat--unpack-u16r) 16))) +(defun bindat--unpack-u64r () + (logior (bindat--unpack-u32r) (ash (bindat--unpack-u32r) 32))) + (defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) @@ -231,16 +238,14 @@ (bindat--unpack-u8)) ((or 'u16 'word 'short) (bindat--unpack-u16)) - ('u24 - (bindat--unpack-u24)) + ('u24 (bindat--unpack-u24)) ((or 'u32 'dword 'long) (bindat--unpack-u32)) - ('u16r - (bindat--unpack-u16r)) - ('u24r - (bindat--unpack-u24r)) - ('u32r - (bindat--unpack-u32r)) + ('u64 (bindat--unpack-u64)) + ('u16r (bindat--unpack-u16r)) + ('u24r (bindat--unpack-u24r)) + ('u32r (bindat--unpack-u32r)) + ('u64r (bindat--unpack-u64r)) ('bits (let ((bits nil) (bnum (1- (* 8 len))) j m) (while (>= bnum 0) @@ -374,6 +379,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (u16 . 2) (u16r . 2) (word . 2) (short . 2) (u24 . 3) (u24r . 3) (u32 . 4) (u32r . 4) (dword . 4) (long . 4) + (u64 . 8) (u64r . 8) (ip . 4))) (defun bindat--length-group (struct spec) @@ -471,6 +477,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16 (ash v -16)) (bindat--pack-u16 v)) +(defun bindat--pack-u64 (v) + (bindat--pack-u32 (ash v -32)) + (bindat--pack-u32 v)) + (defun bindat--pack-u16r (v) (aset bindat-raw (1+ bindat-idx) (logand (ash v -8) 255)) (aset bindat-raw bindat-idx (logand v 255)) @@ -484,6 +494,10 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16r v) (bindat--pack-u16r (ash v -16))) +(defun bindat--pack-u64r (v) + (bindat--pack-u32r v) + (bindat--pack-u32r (ash v -32))) + (defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) @@ -498,12 +512,11 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u24 v)) ((or 'u32 'dword 'long) (bindat--pack-u32 v)) - ('u16r - (bindat--pack-u16r v)) - ('u24r - (bindat--pack-u24r v)) - ('u32r - (bindat--pack-u32r v)) + ('u64 (bindat--pack-u64 v)) + ('u16r (bindat--pack-u16r v)) + ('u24r (bindat--pack-u24r v)) + ('u32r (bindat--pack-u32r v)) + ('u64r (bindat--pack-u64r v)) ('bits (let ((bnum (1- (* 8 len))) j m) (while (>= bnum 0) @@ -518,11 +531,9 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." j (ash j -1)))) (bindat--pack-u8 m)))) ((or 'str 'strz) - (let ((l (length v))) - (if (> l len) (setq l len)) - (dotimes (i l) - (aset bindat-raw (+ bindat-idx i) (aref v i))) - (setq bindat-idx (+ bindat-idx len)))) + (dotimes (i (min len (length v))) + (aset bindat-raw (+ bindat-idx i) (aref v i))) + (setq bindat-idx (+ bindat-idx len))) ('vec (let ((l (length v)) (vlen 1)) (if (consp vectype) -- cgit v1.2.3 From b3e34643c41399239f4846c28221b678804e370b Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 17 Feb 2021 12:01:27 +0100 Subject: Change name for the completion-* predicates * lisp/simple.el (command-completion-default-include-p) (command-completion-with-modes-p, command-completion-button-p): Rename from completion-*. (read-extended-command-predicate): Adjust default predicate. * lisp/emacs-lisp/byte-run.el (byte-run--set-modes): Adjust predicate name. --- lisp/emacs-lisp/byte-run.el | 5 +++-- lisp/simple.el | 11 ++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 8a22388f1d7..76e7f01ace6 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -154,8 +154,9 @@ The return value of this function is not used." (defalias 'byte-run--set-modes #'(lambda (f _args &rest val) (list 'function-put (list 'quote f) - ''completion-predicate `(lambda (_ b) - (completion-with-modes-p ',val b))))) + ''completion-predicate + `(lambda (_ b) + (command-completion-with-modes-p ',val b))))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist diff --git a/lisp/simple.el b/lisp/simple.el index 215f4399f4a..248d044b19c 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1904,7 +1904,8 @@ to get different commands to edit and resubmit." (defvar extended-command-history nil) (defvar execute-extended-command--last-typed nil) -(defcustom read-extended-command-predicate #'completion-default-include-p +(defcustom read-extended-command-predicate + #'command-completion-default-include-p "Predicate to use to determine which commands to include when completing. The predicate function is called with two parameters: The symbol (i.e., command) in question that should be included or @@ -1912,7 +1913,7 @@ not, and the current buffer. The predicate should return non-nil if the command should be present when doing `M-x TAB'." :version "28.1" :type `(choice (const :tag "Exclude commands not relevant to the current mode" - completion-default-include-p) + command-completion-default-include-p) (const :tag "All commands" ,(lambda (_s _b) t)) (function :tag "Other function"))) @@ -1973,7 +1974,7 @@ This function uses the `read-extended-command-predicate' user option." (funcall read-extended-command-predicate sym buffer))) t nil 'extended-command-history)))) -(defun completion-default-include-p (symbol buffer) +(defun command-completion-default-include-p (symbol buffer) "Say whether SYMBOL should be offered as a completion. If there's a `completion-predicate' for SYMBOL, the result from calling that predicate is called. If there isn't one, this @@ -2002,7 +2003,7 @@ BUFFER." #'eq) (seq-intersection modes global-minor-modes #'eq)))))) -(defun completion-with-modes-p (modes buffer) +(defun command-completion-with-modes-p (modes buffer) "Say whether MODES are in action in BUFFER. This is the case if either the major mode is derived from one of MODES, or (if one of MODES is a minor mode), if it is switched on in BUFFER." @@ -2015,7 +2016,7 @@ or (if one of MODES is a minor mode), if it is switched on in BUFFER." #'eq) (seq-intersection modes global-minor-modes #'eq))) -(defun completion-button-p (category buffer) +(defun command-completion-button-p (category buffer) "Return non-nil if there's a button of CATEGORY at point in BUFFER." (with-current-buffer buffer (and (get-text-property (point) 'button) -- cgit v1.2.3 From 0324ec17375028bd1b26a6d695535450d5a5a9c5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 17 Feb 2021 17:12:27 +0100 Subject: Fix recently introduced bug in `byte-compile-lambda' * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Fix recently introduced error when compiling non-lexical commands (bug#46589). --- lisp/emacs-lisp/bytecomp.el | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5c6b9c2e39a..9d80afd774f 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2951,7 +2951,9 @@ for symbols generated by the byte compiler itself." ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) - (cond ((consp (cdr int)) + (cond ((consp (cdr int)) ; There is an `interactive' spec. + ;; Check that the bit after the `interactive' spec is + ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) (byte-compile-warn "malformed interactive specc: %s" (prin1-to-string int))) @@ -2966,16 +2968,14 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (setq int - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - `(interactive ,form) - `(interactive ,newform))))) - ((cdr int) + (when (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(interactive ,newform))))) + ((cdr int) ; Invalid (interactive . something). (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) ;; Process the body. -- cgit v1.2.3 From 6735bb3d22dc64f3fe42e4a7f439ea9d62f75b5a Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 17 Feb 2021 20:59:44 +0100 Subject: Adjust the edebug spec for `interactive' * lisp/emacs-lisp/edebug.el: Adjust the edebug spec for `interactive' for the new syntax. --- lisp/emacs-lisp/edebug.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 7fae4d21d50..45996945948 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -2136,7 +2136,8 @@ SPEC is the symbol name prefix for `gensym'." ;; more convenient to define their Edebug spec here. (defun ( &define name lambda-list lambda-doc [&optional ("declare" def-declarations)] - [&optional ("interactive" &optional &or stringp def-form)] + [&optional ("interactive" &optional [&or stringp def-form] + &rest symbolp)] def-body)) (defmacro ( &define name lambda-list lambda-doc @@ -2192,7 +2193,8 @@ SPEC is the symbol name prefix for `gensym'." '(&optional [&or stringp (&define ":documentation" def-form)])) -(def-edebug-elem-spec 'interactive '(&optional &or stringp def-form)) +(def-edebug-elem-spec 'interactive '(&optional [&or stringp def-form] + &rest symbolp)) ;; A function-form is for an argument that may be a function or a form. ;; This specially recognizes anonymous functions quoted with quote. -- cgit v1.2.3