From b939f7ad359807e846831a9854e0d94260d9f084 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 14 Feb 2021 21:13:35 -0500 Subject: [PATCH] * 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(-) 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 -- 2.39.2