Move backtrace to ELisp using a new mapbacktrace primitive
* src/eval.c (get_backtrace_starting_at, backtrace_frame_apply) (Fmapbacktrace, Fbacktrace_frame_internal): New functions. (get_backtrace_frame, Fbacktrace_debug): Use `get_backtrace_starting_at'. * lisp/subr.el (backtrace--print-frame): New function. (backtrace): Reimplement using `backtrace--print-frame' and `mapbacktrace'. (backtrace-frame): Reimplement using `backtrace-frame--internal'. * lisp/emacs-lisp/debug.el (debugger-setup-buffer): Pass a base to `mapbacktrace' instead of searching for "(debug" in the output of `backtrace'. * test/lisp/subr-tests.el (subr-test-backtrace-simple-tests) (subr-test-backtrace-integration-test): New tests. * doc/lispref/debugging.texi (Internals of Debugger): Document `mapbacktrace' and missing argument BASE of `backtrace-frame'.
This commit is contained in:
Clément Pit--Claudel
parent
a41ded87b3
commit
27cada035a
6 changed files with 197 additions and 100 deletions
|
|
@ -727,7 +727,7 @@ invocation.
|
|||
This variable is obsolete and will be removed in future versions.
|
||||
@end defvar
|
||||
|
||||
@defun backtrace-frame frame-number
|
||||
@defun backtrace-frame frame-number &optional base
|
||||
The function @code{backtrace-frame} is intended for use in Lisp
|
||||
debuggers. It returns information about what computation is happening
|
||||
in the stack frame @var{frame-number} levels down.
|
||||
|
|
@ -744,10 +744,31 @@ In the return value, @var{function} is whatever was supplied as the
|
|||
case of a macro call. If the function has a @code{&rest} argument, that
|
||||
is represented as the tail of the list @var{arg-values}.
|
||||
|
||||
If @var{base} is specified, @var{frame-number} counts relative to
|
||||
the topmost frame whose @var{function} is @var{base}.
|
||||
|
||||
If @var{frame-number} is out of range, @code{backtrace-frame} returns
|
||||
@code{nil}.
|
||||
@end defun
|
||||
|
||||
@defun mapbacktrace function &optional base
|
||||
The function @code{mapbacktrace} calls @var{function} once for each
|
||||
frame in the backtrace, starting at the first frame whose function is
|
||||
@var{base} (or from the top if @var{base} is omitted or @code{nil}).
|
||||
|
||||
@var{function} is called with four arguments: @var{evald}, @var{func},
|
||||
@var{args}, and @var{flags}.
|
||||
|
||||
If a frame has not evaluated its arguments yet or is a special form,
|
||||
@var{evald} is @code{nil} and @var{args} is a list of forms.
|
||||
|
||||
If a frame has evaluated its arguments and called its function
|
||||
already, @var{evald} is @code{t} and @var{args} is a list of values.
|
||||
@var{flags} is a plist of properties of the current frame: currently,
|
||||
the only supported property is @code{:debug-on-exit}, which is
|
||||
@code{t} if the stack frame's @code{debug-on-exit} flag is set.
|
||||
@end defun
|
||||
|
||||
@include edebug.texi
|
||||
|
||||
@node Syntax Errors
|
||||
|
|
|
|||
4
etc/NEWS
4
etc/NEWS
|
|
@ -73,6 +73,10 @@ for '--daemon'.
|
|||
|
||||
* Changes in Emacs 26.1
|
||||
|
||||
+++
|
||||
** The new function 'mapbacktrace' applies a function to all frames of
|
||||
the current stack trace.
|
||||
|
||||
+++
|
||||
** Emacs now provides a limited form of concurrency with Lisp threads.
|
||||
Concurrency in Emacs Lisp is "mostly cooperative", meaning that
|
||||
|
|
|
|||
|
|
@ -274,15 +274,14 @@ That buffer should be current already."
|
|||
(let ((standard-output (current-buffer))
|
||||
(print-escape-newlines t)
|
||||
(print-level 8)
|
||||
(print-length 50))
|
||||
(backtrace))
|
||||
(print-length 50))
|
||||
;; FIXME the debugger could pass a custom callback to mapbacktrace
|
||||
;; instead of manipulating printed results.
|
||||
(mapbacktrace #'backtrace--print-frame 'debug))
|
||||
(goto-char (point-min))
|
||||
(delete-region (point)
|
||||
(progn
|
||||
(search-forward (if debugger-stack-frame-as-list
|
||||
"\n (debug "
|
||||
"\n debug("))
|
||||
(forward-line (if (eq (car args) 'debug)
|
||||
(forward-line (if (eq (car args) 'debug)
|
||||
;; Remove debug--implement-debug-on-entry
|
||||
;; and the advice's `apply' frame.
|
||||
3
|
||||
|
|
|
|||
45
lisp/subr.el
45
lisp/subr.el
|
|
@ -4334,6 +4334,51 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
|
|||
(put symbol 'sendfunc sendfunc)
|
||||
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
|
||||
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
|
||||
|
||||
|
||||
(defun backtrace--print-frame (evald func args flags)
|
||||
"Print a trace of a single stack frame to `standard-output'.
|
||||
EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'."
|
||||
(princ (if (plist-get flags :debug-on-exit) "* " " "))
|
||||
(cond
|
||||
((and evald (not debugger-stack-frame-as-list))
|
||||
(prin1 func)
|
||||
(if args (prin1 args) (princ "()")))
|
||||
(t
|
||||
(prin1 (cons func args))))
|
||||
(princ "\n"))
|
||||
|
||||
(defun backtrace ()
|
||||
"Print a trace of Lisp function calls currently active.
|
||||
Output stream used is value of `standard-output'."
|
||||
(let ((print-level (or print-level 8)))
|
||||
(mapbacktrace #'backtrace--print-frame 'backtrace)))
|
||||
|
||||
(defun backtrace-frames (&optional base)
|
||||
"Collect all frames of current backtrace into a list.
|
||||
If non-nil, BASE should be a function, and frames before its
|
||||
nearest activation frames are discarded."
|
||||
(let ((frames nil))
|
||||
(mapbacktrace (lambda (&rest frame) (push frame frames))
|
||||
(or base 'backtrace-frames))
|
||||
(nreverse frames)))
|
||||
|
||||
(defun backtrace-frame (nframes &optional base)
|
||||
"Return the function and arguments NFRAMES up from current execution point.
|
||||
If non-nil, BASE should be a function, and NFRAMES counts from its
|
||||
nearest activation frame.
|
||||
If the frame has not evaluated the arguments yet (or is a special form),
|
||||
the value is (nil FUNCTION ARG-FORMS...).
|
||||
If the frame has evaluated its arguments and called its function already,
|
||||
the value is (t FUNCTION ARG-VALUES...).
|
||||
A &rest arg is represented as the tail of the list ARG-VALUES.
|
||||
FUNCTION is whatever was supplied as car of evaluated list,
|
||||
or a lambda expression for macro calls.
|
||||
If NFRAMES is more than the number of frames, the value is nil."
|
||||
(backtrace-frame--internal
|
||||
(lambda (evald func args _) `(,evald ,func ,@args))
|
||||
nframes (or base 'backtrace-frame)))
|
||||
|
||||
|
||||
(defvar called-interactively-p-functions nil
|
||||
"Special hook called to skip special frames in `called-interactively-p'.
|
||||
|
|
|
|||
167
src/eval.c
167
src/eval.c
|
|
@ -3541,88 +3541,30 @@ context where binding is lexical by default. */)
|
|||
}
|
||||
|
||||
|
||||
DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
|
||||
doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
|
||||
The debugger is entered when that frame exits, if the flag is non-nil. */)
|
||||
(Lisp_Object level, Lisp_Object flag)
|
||||
{
|
||||
union specbinding *pdl = backtrace_top ();
|
||||
register EMACS_INT i;
|
||||
|
||||
CHECK_NUMBER (level);
|
||||
|
||||
for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
|
||||
pdl = backtrace_next (pdl);
|
||||
|
||||
if (backtrace_p (pdl))
|
||||
set_backtrace_debug_on_exit (pdl, !NILP (flag));
|
||||
|
||||
return flag;
|
||||
}
|
||||
|
||||
DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
|
||||
doc: /* Print a trace of Lisp function calls currently active.
|
||||
Output stream used is value of `standard-output'. */)
|
||||
(void)
|
||||
{
|
||||
union specbinding *pdl = backtrace_top ();
|
||||
Lisp_Object tem;
|
||||
Lisp_Object old_print_level = Vprint_level;
|
||||
|
||||
if (NILP (Vprint_level))
|
||||
XSETFASTINT (Vprint_level, 8);
|
||||
|
||||
while (backtrace_p (pdl))
|
||||
{
|
||||
write_string (backtrace_debug_on_exit (pdl) ? "* " : " ");
|
||||
if (backtrace_nargs (pdl) == UNEVALLED)
|
||||
{
|
||||
Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
|
||||
Qnil);
|
||||
write_string ("\n");
|
||||
}
|
||||
else
|
||||
{
|
||||
tem = backtrace_function (pdl);
|
||||
if (debugger_stack_frame_as_list)
|
||||
write_string ("(");
|
||||
Fprin1 (tem, Qnil); /* This can QUIT. */
|
||||
if (!debugger_stack_frame_as_list)
|
||||
write_string ("(");
|
||||
{
|
||||
ptrdiff_t i;
|
||||
for (i = 0; i < backtrace_nargs (pdl); i++)
|
||||
{
|
||||
if (i || debugger_stack_frame_as_list)
|
||||
write_string(" ");
|
||||
Fprin1 (backtrace_args (pdl)[i], Qnil);
|
||||
}
|
||||
}
|
||||
write_string (")\n");
|
||||
}
|
||||
pdl = backtrace_next (pdl);
|
||||
}
|
||||
|
||||
Vprint_level = old_print_level;
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
static union specbinding *
|
||||
get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
|
||||
get_backtrace_starting_at (Lisp_Object base)
|
||||
{
|
||||
union specbinding *pdl = backtrace_top ();
|
||||
register EMACS_INT i;
|
||||
|
||||
CHECK_NATNUM (nframes);
|
||||
|
||||
if (!NILP (base))
|
||||
{ /* Skip up to `base'. */
|
||||
base = Findirect_function (base, Qt);
|
||||
while (backtrace_p (pdl)
|
||||
&& !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
|
||||
pdl = backtrace_next (pdl);
|
||||
&& !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
|
||||
pdl = backtrace_next (pdl);
|
||||
}
|
||||
|
||||
return pdl;
|
||||
}
|
||||
|
||||
static union specbinding *
|
||||
get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
|
||||
{
|
||||
register EMACS_INT i;
|
||||
|
||||
CHECK_NATNUM (nframes);
|
||||
union specbinding *pdl = get_backtrace_starting_at (base);
|
||||
|
||||
/* Find the frame requested. */
|
||||
for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
|
||||
pdl = backtrace_next (pdl);
|
||||
|
|
@ -3630,35 +3572,73 @@ get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
|
|||
return pdl;
|
||||
}
|
||||
|
||||
DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL,
|
||||
doc: /* Return the function and arguments NFRAMES up from current execution point.
|
||||
If that frame has not evaluated the arguments yet (or is a special form),
|
||||
the value is (nil FUNCTION ARG-FORMS...).
|
||||
If that frame has evaluated its arguments and called its function already,
|
||||
the value is (t FUNCTION ARG-VALUES...).
|
||||
A &rest arg is represented as the tail of the list ARG-VALUES.
|
||||
FUNCTION is whatever was supplied as car of evaluated list,
|
||||
or a lambda expression for macro calls.
|
||||
If NFRAMES is more than the number of frames, the value is nil.
|
||||
If BASE is non-nil, it should be a function and NFRAMES counts from its
|
||||
nearest activation frame. */)
|
||||
(Lisp_Object nframes, Lisp_Object base)
|
||||
static Lisp_Object
|
||||
backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
|
||||
{
|
||||
union specbinding *pdl = get_backtrace_frame (nframes, base);
|
||||
|
||||
if (!backtrace_p (pdl))
|
||||
return Qnil;
|
||||
|
||||
Lisp_Object flags = Qnil;
|
||||
if (backtrace_debug_on_exit (pdl))
|
||||
flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
|
||||
|
||||
if (backtrace_nargs (pdl) == UNEVALLED)
|
||||
return Fcons (Qnil,
|
||||
Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
|
||||
return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
|
||||
else
|
||||
{
|
||||
Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
|
||||
|
||||
return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
|
||||
return call4 (function, Qt, backtrace_function (pdl), tem, flags);
|
||||
}
|
||||
}
|
||||
|
||||
DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
|
||||
doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
|
||||
The debugger is entered when that frame exits, if the flag is non-nil. */)
|
||||
(Lisp_Object level, Lisp_Object flag)
|
||||
{
|
||||
CHECK_NUMBER (level);
|
||||
union specbinding *pdl = get_backtrace_frame(level, Qnil);
|
||||
|
||||
if (backtrace_p (pdl))
|
||||
set_backtrace_debug_on_exit (pdl, !NILP (flag));
|
||||
|
||||
return flag;
|
||||
}
|
||||
|
||||
DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
|
||||
doc: /* Call FUNCTION for each frame in backtrace.
|
||||
If BASE is non-nil, it should be a function and iteration will start
|
||||
from its nearest activation frame.
|
||||
FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
|
||||
a frame has not evaluated its arguments yet or is a special form,
|
||||
EVALD is nil and ARGS is a list of forms. If a frame has evaluated
|
||||
its arguments and called its function already, EVALD is t and ARGS is
|
||||
a list of values.
|
||||
FLAGS is a plist of properties of the current frame: currently, the
|
||||
only supported property is :debug-on-exit. `mapbacktrace' always
|
||||
returns nil. */)
|
||||
(Lisp_Object function, Lisp_Object base)
|
||||
{
|
||||
union specbinding *pdl = get_backtrace_starting_at (base);
|
||||
|
||||
while (backtrace_p (pdl))
|
||||
{
|
||||
backtrace_frame_apply (function, pdl);
|
||||
pdl = backtrace_next (pdl);
|
||||
}
|
||||
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal,
|
||||
Sbacktrace_frame_internal, 3, 3, NULL,
|
||||
doc: /* Call FUNCTION on stack frame NFRAMES away from BASE.
|
||||
Return the result of FUNCTION, or nil if no matching frame could be found. */)
|
||||
(Lisp_Object function, Lisp_Object nframes, Lisp_Object base)
|
||||
{
|
||||
return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
|
||||
}
|
||||
|
||||
/* For backtrace-eval, we want to temporarily unwind the last few elements of
|
||||
the specpdl stack, and then rewind them. We store the pre-unwind values
|
||||
directly in the pre-existing specpdl elements (i.e. we swap the current
|
||||
|
|
@ -4114,8 +4094,9 @@ alist of active lexical bindings. */);
|
|||
defsubr (&Srun_hook_wrapped);
|
||||
defsubr (&Sfetch_bytecode);
|
||||
defsubr (&Sbacktrace_debug);
|
||||
defsubr (&Sbacktrace);
|
||||
defsubr (&Sbacktrace_frame);
|
||||
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
|
||||
defsubr (&Smapbacktrace);
|
||||
defsubr (&Sbacktrace_frame_internal);
|
||||
defsubr (&Sbacktrace_eval);
|
||||
defsubr (&Sbacktrace__locals);
|
||||
defsubr (&Sspecial_variable_p);
|
||||
|
|
|
|||
|
|
@ -224,5 +224,52 @@
|
|||
(error-message-string (should-error (version-to-list "beta22_8alpha3")))
|
||||
"Invalid version syntax: `beta22_8alpha3' (must start with a number)"))))
|
||||
|
||||
(defun subr-test--backtrace-frames-with-backtrace-frame (base)
|
||||
"Reference implementation of `backtrace-frames'."
|
||||
(let ((idx 0)
|
||||
(frame nil)
|
||||
(frames nil))
|
||||
(while (setq frame (backtrace-frame idx base))
|
||||
(push frame frames)
|
||||
(setq idx (1+ idx)))
|
||||
(nreverse frames)))
|
||||
|
||||
(defun subr-test--frames-2 (base)
|
||||
(let ((_dummy nil))
|
||||
(progn ;; Add a few frames to top of stack
|
||||
(unwind-protect
|
||||
(cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_))
|
||||
`(,evald ,func ,@args))
|
||||
(backtrace-frames base))
|
||||
(subr-test--backtrace-frames-with-backtrace-frame base))))))
|
||||
|
||||
(defun subr-test--frames-1 (base)
|
||||
(subr-test--frames-2 base))
|
||||
|
||||
(ert-deftest subr-test-backtrace-simple-tests ()
|
||||
"Test backtrace-related functions (simple tests).
|
||||
This exercises `backtrace-frame', and indirectly `mapbacktrace'."
|
||||
;; `mapbacktrace' returns nil
|
||||
(should (equal (mapbacktrace #'ignore) nil))
|
||||
;; Unbound BASE is silently ignored
|
||||
(let ((unbound (make-symbol "ub")))
|
||||
(should (equal (backtrace-frame 0 unbound) nil))
|
||||
(should (equal (mapbacktrace #'error unbound) nil)))
|
||||
;; First frame is backtrace-related function
|
||||
(should (equal (backtrace-frame 0) '(t backtrace-frame 0)))
|
||||
(should (equal (catch 'ret
|
||||
(mapbacktrace (lambda (&rest args) (throw 'ret args))))
|
||||
'(t mapbacktrace ((lambda (&rest args) (throw 'ret args))) nil)))
|
||||
;; Past-end NFRAMES is silently ignored
|
||||
(should (equal (backtrace-frame most-positive-fixnum) nil)))
|
||||
|
||||
(ert-deftest subr-test-backtrace-integration-test ()
|
||||
"Test backtrace-related functions (integration test).
|
||||
This exercises `backtrace-frame', `backtrace-frames', and
|
||||
indirectly `mapbacktrace'."
|
||||
;; Compare two implementations of backtrace-frames
|
||||
(let ((frame-lists (subr-test--frames-1 'subr-test--frames-2)))
|
||||
(should (equal (car frame-lists) (cdr frame-lists)))))
|
||||
|
||||
(provide 'subr-tests)
|
||||
;;; subr-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue