[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master b939f7a: * Edebug: Generalize `&lookup`, use it for `cl-macrolet`
|
From: |
Stefan Monnier |
|
Subject: |
master b939f7a: * Edebug: Generalize `&lookup`, use it for `cl-macrolet` and `cl-generic` |
|
Date: |
Sun, 14 Feb 2021 21:38:30 -0500 (EST) |
branch: master
commit b939f7ad359807e846831a9854e0d94260d9f084
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
* 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 46f5cb9..3868f67 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 33434d5..1adfb8c 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 2296083..279b9d1 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 e2faf6d..b9a8a3f 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 8fadeba..efca730 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 (<name> <spec>) ...
;; where <name> 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 5d428ac..d3928fa 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 d215bd2..490aec9 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 4a01623..9312fb4 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 835d378..9257f16 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 dfe2cb3..d81376e 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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master b939f7a: * Edebug: Generalize `&lookup`, use it for `cl-macrolet` and `cl-generic`,
Stefan Monnier <=