diff options
Diffstat (limited to 'lisp/emacs-lisp/edebug.el')
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 781 |
1 files changed, 344 insertions, 437 deletions
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 5d595851b9f..7def9ff96a7 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 @@ -100,10 +101,6 @@ variable. You may wish to make it local to each buffer with `emacs-lisp-mode-hook'." :type 'boolean) -;; edebug-all-defs and edebug-all-forms need to be autoloaded -;; because the byte compiler binds them; as a result, if edebug -;; is first loaded for a require in a compilation, they will be left unbound. - ;;;###autoload (defcustom edebug-all-forms nil "Non-nil means evaluation of all forms will instrument for Edebug. @@ -244,19 +241,30 @@ 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") + +(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. @@ -445,66 +453,27 @@ the option `edebug-all-forms'." ;; We should somehow arrange to be able to do this ;; without actually replacing the eval-defun command. -(defun edebug-eval-defun (edebug-it) - "Evaluate the top-level form containing point, or after point. - -If the current defun is actually a call to `defvar', then reset the -variable using its initial value expression even if the variable -already has some other value. (Normally `defvar' does not change the -variable's value if it already has a value.) Treat `defcustom' -similarly. Reinitialize the face according to `defface' specification. - -With a prefix argument, instrument the code for Edebug. - -Setting option `edebug-all-defs' to a non-nil value reverses the meaning +(defun edebug--eval-defun (orig-fun edebug-it) + "Setting option `edebug-all-defs' to a non-nil value reverses the meaning of the prefix argument. Code is then instrumented when this function is invoked without a prefix argument. If acting on a `defun' for FUNCTION, and the function was instrumented, `Edebug: FUNCTION' is printed in the minibuffer. If not instrumented, -just FUNCTION is printed. +just FUNCTION is printed." + ;; Re-install our advice, in case `debug' re-bound `load-read-function' to + ;; its default value. + (add-function :around load-read-function #'edebug--read) + (let* ((edebug-all-forms (not (eq (not edebug-it) (not edebug-all-defs)))) + (edebug-all-defs edebug-all-forms)) + (funcall orig-fun nil))) -If not acting on a `defun', the result of evaluation is displayed in -the minibuffer." +(defun edebug-eval-defun (edebug-it) + (declare (obsolete "use eval-defun or edebug--eval-defun instead" "28.1")) (interactive "P") - (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs)))) - (edebug-result) - (form - (let ((edebug-all-forms edebugging) - (edebug-all-defs (eq edebug-all-defs (not edebug-it)))) - (edebug-read-top-level-form)))) - ;; This should be consistent with `eval-defun-1', but not the - ;; same, since that gets a macroexpanded form. - (cond ((and (eq (car form) 'defvar) - (cdr-safe (cdr-safe form))) - ;; Force variable to be bound. - (makunbound (nth 1 form))) - ((and (eq (car form) 'defcustom) - (default-boundp (nth 1 form))) - ;; Force variable to be bound. - ;; FIXME: Shouldn't this use the :setter or :initializer? - (set-default (nth 1 form) (eval (nth 2 form) lexical-binding))) - ((eq (car form) 'defface) - ;; Reset the face. - (setq face-new-frame-defaults - (assq-delete-all (nth 1 form) face-new-frame-defaults)) - (put (nth 1 form) 'face-defface-spec nil) - (put (nth 1 form) 'face-documentation (nth 3 form)) - ;; See comments in `eval-defun-1' for purpose of code below - (setq form (prog1 `(prog1 ,form - (put ',(nth 1 form) 'saved-face - ',(get (nth 1 form) 'saved-face)) - (put ',(nth 1 form) 'customized-face - ,(nth 2 form))) - (put (nth 1 form) 'saved-face nil))))) - (setq edebug-result (eval (eval-sexp-add-defvars form) lexical-binding)) - (if (not edebugging) - (prog1 - (prin1 edebug-result) - (let ((str (eval-expression-print-format edebug-result))) - (if str (princ str)))) - edebug-result))) - + (if (advice-member-p #'edebug--eval-defun 'eval-defun) + (eval-defun edebug-it) + (edebug--eval-defun #'eval-defun edebug-it))) ;;;###autoload (defalias 'edebug-defun 'edebug-eval-top-level-form) @@ -576,12 +545,12 @@ already is one.)" (defun edebug-install-read-eval-functions () (interactive) (add-function :around load-read-function #'edebug--read) - (advice-add 'eval-defun :override #'edebug-eval-defun)) + (advice-add 'eval-defun :around #'edebug--eval-defun)) (defun edebug-uninstall-read-eval-functions () (interactive) (remove-function load-read-function #'edebug--read) - (advice-remove 'eval-defun #'edebug-eval-defun)) + (advice-remove 'eval-defun #'edebug--eval-defun)) ;;; Edebug internal data @@ -961,6 +930,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 +996,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) @@ -1067,8 +1048,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 @@ -1119,8 +1098,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 @@ -1153,7 +1130,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. @@ -1164,6 +1141,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, @@ -1211,26 +1191,12 @@ 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))) +(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. @@ -1380,7 +1346,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. ) @@ -1500,9 +1465,12 @@ 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) (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,13 +1510,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 (get-edebug-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) @@ -1562,7 +1527,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))) @@ -1575,10 +1540,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))) @@ -1586,11 +1548,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)))))) @@ -1628,7 +1585,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)) @@ -1639,13 +1596,11 @@ 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 ) - (edebug-match-specs cursor specs 'edebug-match-specs))) + (edebug-match-specs cursor specs #'edebug-match-specs))) (defun edebug-match-one-spec (cursor spec) @@ -1687,10 +1642,10 @@ contains a circular object." (first-char (and (symbolp spec) (aref (symbol-name spec) 0))) (match (cond ((eq ?& first-char);; "&" symbols take all following specs. - (funcall (get-edebug-spec 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))) - (funcall (get-edebug-spec spec) cursor (car (cdr specs)))) + (edebug--handle-:-spec-op spec cursor (car (cdr specs)))) (t;; Any other normal spec. (setq rest (cdr specs)) (edebug-match-one-spec cursor spec))))) @@ -1721,40 +1676,23 @@ contains a circular object." ;; user may want to define macros or functions with the same names. ;; We could use an internal obarray for these primitive specs. -(dolist (pair '((&optional . edebug-match-&optional) - (&rest . edebug-match-&rest) - (&or . edebug-match-&or) - (form . edebug-match-form) +(dolist (pair '((form . edebug-match-form) (sexp . edebug-match-sexp) (body . edebug-match-body) - (&define . edebug-match-&define) - (name . edebug-match-name) - (:name . edebug-match-colon-name) - (:unique . edebug-match-:unique) (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) - (¬ . edebug-match-¬) - (&key . edebug-match-&key) - (&error . edebug-match-&error) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. )) - (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. - (let* ((spec (get-edebug-spec symbol))) + (let* ((spec (edebug--get-elem-spec symbol))) (cond (spec (if (consp spec) @@ -1793,13 +1731,12 @@ contains a circular object." (defsubst edebug-match-body (cursor) (edebug-forms cursor)) -(defun edebug-match-&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)) + (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))) @@ -1814,20 +1751,24 @@ 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.") -(defun edebug-match-&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 + (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))))) -(defun edebug-match-&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. @@ -1851,24 +1792,49 @@ contains a circular object." (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) - -(defun edebug-match-¬ (cursor specs) +(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 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)))) + (head (seq-subseq exps 0 consumed))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (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-match-&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 -(defun edebug-match-&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-match-&rest + (edebug--match-&-spec-op + '&rest cursor (cons '&or (mapcar (lambda (pair) @@ -1876,7 +1842,7 @@ contains a circular object." (car (cdr pair)))) specs)))) -(defun edebug-match-&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))) @@ -1945,19 +1911,15 @@ contains a circular object." (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) @@ -1980,61 +1942,83 @@ contains a circular object." (defun edebug-match-function (_cursor) (error "Use function-form instead of function in edebug spec")) -(defun edebug-match-&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 ;; of the current list. e.g. ("lambda" &define args def-body) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - ;; Find the last offset in the list. - (let ((offsets (edebug-cursor-offsets cursor))) - (while (consp offsets) (setq offsets (cdr offsets))) - 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) (get-edebug-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") - ))) - - -(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))) - -(defun edebug-match-colon-name (_cursor spec) + (prog1 (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + ;; Find the last offset in the list. + (let ((offsets (edebug-cursor-offsets cursor))) + (while (consp offsets) (setq offsets (cdr offsets))) + offsets) + specs) + ;; Stop backtracking here (Bug#41988). + (setq edebug-gate t))) + +(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: + &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. +:foo spec operators operate on just the one subsequent SPEC element.") + +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :name)) _cursor spec) ;; Set the edebug-def-name to the spec. (setq edebug-def-name (if edebug-def-name @@ -2043,7 +2027,7 @@ contains a circular object." spec)) nil) -(defun edebug-match-:unique (_cursor spec) +(cl-defmethod edebug--handle-:-spec-op ((_ (eql :unique)) _cursor spec) "Match a `:unique PREFIX' specifier. SPEC is the symbol name prefix for `gensym'." (let ((suffix (gensym spec))) @@ -2054,63 +2038,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 - "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"))) @@ -2139,151 +2066,135 @@ 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 ;;; ========================================================== -;;;;* 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. -(def-edebug-spec quote sexp) +(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" def-declarations)] + [&optional ("interactive" &optional [&or stringp def-form] + &rest symbolp)] + def-body)) + + (defmacro ( &define name lambda-list lambda-doc + [&optional ("declare" def-declarations)] + 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)) + +(defun edebug--match-declare-arg (head pf) + (funcall pf (get (car head) 'edebug-declaration-spec))) -;; The standard defining forms. -(def-edebug-spec defconst defvar) -(def-edebug-spec defvar (symbolp &optional form stringp)) +(def-edebug-elem-spec 'def-declarations + '(&rest &or (&interpose symbolp edebug--match-declare-arg) sexp)) -(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-elem-spec 'lambda-list + '(([&rest arg] + [&optional ["&optional" arg &rest arg]] + &optional ["&rest" arg] + ))) -(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list. +(def-edebug-elem-spec 'lambda-expr + '(("lambda" &define lambda-list lambda-doc + [&optional ("interactive" interactive)] + def-body))) -(def-edebug-spec lambda-list - (([&rest arg] - [&optional ["&optional" arg &rest arg]] - &optional ["&rest" arg] - ))) +(def-edebug-elem-spec 'arglist '(lambda-list)) ;; deprecated - use lambda-list. -(def-edebug-spec lambda-doc - (&optional [&or stringp - (&define ":documentation" def-form)])) +(def-edebug-elem-spec 'lambda-doc + '(&optional [&or stringp + (&define ":documentation" def-form)])) -(def-edebug-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. -(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 @@ -2298,20 +2209,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 @@ -2485,11 +2385,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) @@ -2921,7 +2820,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. @@ -2937,7 +2835,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 @@ -3601,7 +3498,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,9 +3513,9 @@ 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 +The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read @@ -3801,9 +3701,10 @@ Print result in minibuffer." (interactive (list (read--expression "Eval: "))) (princ (edebug-outside-excursion - (setq values (cons (edebug-eval expr) values)) - (concat (edebug-safe-prin1-to-string (car values)) - (eval-expression-print-format (car values)))))) + (let ((result (edebug-eval expr))) + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result)))))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. @@ -3936,10 +3837,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) @@ -3972,9 +3877,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 () @@ -4216,12 +4121,12 @@ This should be a list of `edebug---frame' objects.") "Stack frames of the current Edebug Backtrace buffer with instrumentation. This should be a list of `edebug---frame' objects.") -;; Data structure for backtrace frames with information -;; from Edebug instrumentation found in the backtrace. (cl-defstruct (edebug--frame (:constructor edebug--make-frame) (:include backtrace-frame)) + "Data structure for backtrace frames with information +from Edebug instrumentation found in the backtrace." def-name before-index after-index) (defun edebug-pop-to-backtrace () @@ -4236,7 +4141,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) @@ -4470,10 +4376,6 @@ It is removed when you hit any char." (set variable (not (symbol-value variable))) (message "%s: %s" variable (symbol-value variable))) -;; We have to require easymenu (even for Emacs 18) just so -;; the easy-menu-define macro call is compiled correctly. -(require 'easymenu) - (defconst edebug-mode-menus '("Edebug" ["Stop" edebug-stop t] @@ -4578,13 +4480,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. |