From 185736cd23be13677ef3528cf83ef4a4f3039c72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Pit--Claudel?= Date: Mon, 5 Dec 2016 00:52:14 -0500 Subject: [PATCH] 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'. * doc/lispref/debugging.texi (Internals of Debugger): Document `mapbacktrace' and missing argument BASE of `backtrace-frame'. --- doc/lispref/debugging.texi | 24 ++++++- etc/NEWS | 4 ++ lisp/emacs-lisp/debug.el | 11 ++-- lisp/subr.el | 36 ++++++++++ src/eval.c | 160 ++++++++++++++++++++------------------------- 5 files changed, 140 insertions(+), 95 deletions(-) diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi index c80b0f9..35ff9af 100644 --- a/doc/lispref/debugging.texi +++ b/doc/lispref/debugging.texi @@ -727,7 +727,7 @@ Internals of Debugger This variable is obsolete and will be removed in future versions. @end defvar address@hidden backtrace-frame frame-number address@hidden 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,32 @@ Internals of Debugger 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 address@hidden mapbacktrace function &optional base +The function @code{mapbacktrace} calls @var{function} once for each +frame in the backtrace, starting at the first frame whose address@hidden is base (or from the top if @var{base} is omitted or address@hidden). + address@hidden is called with four arguments @var{evald} @var{func} address@hidden @var{flags}. + +If a frame has not evaluated its arguments yet or is a special form, address@hidden 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. address@hidden is a plist of properties of the current frame: currently, +the only supported property is @code{:debug-on-exit}, which is t if +the frame's debug-on-exit flag is set. address@hidden defun + @include edebug.texi @node Syntax Errors diff --git a/etc/NEWS b/etc/NEWS index a62668a..72bef06 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -74,6 +74,10 @@ for '--daemon'. * Changes in Emacs 26.1 +++ +** The new function 'mapbacktrace' applies a function to all frames of +the current stack trace. + ++++ ** The new function 'file-name-case-insensitive-p' tests whether a given file is on a case-insensitive filesystem. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 5430b72..5a4b097 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -274,15 +274,14 @@ debugger-setup-buffer (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 diff --git a/lisp/subr.el b/lisp/subr.el index 5da5bf8..cb32e66 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -4333,6 +4333,42 @@ define-mail-user-agent (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-frame (nframes &optional base) + "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." + (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'. diff --git a/src/eval.c b/src/eval.c index 724f001..9baa811 100644 --- a/src/eval.c +++ b/src/eval.c @@ -3401,87 +3401,29 @@ 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) +static union specbinding * +get_backtrace_starting_at (Lisp_Object base) { 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); + 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); } - Vprint_level = old_print_level; - return Qnil; + return pdl; } static union specbinding * get_backtrace_frame (Lisp_Object nframes, 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); - } + union specbinding *pdl = get_backtrace_starting_at (base); /* Find the frame requested. */ for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--) @@ -3490,33 +3432,74 @@ 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) +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 call4 (function, Qt, backtrace_function (pdl), tem, flags); + } +} - return Fcons (Qt, Fcons (backtrace_function (pdl), tem)); +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. +FUNCTION is called with 4 arguments EVALD FUNC ARGS 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. +If BASE is non-nil, it should be a function and iteration will start +from its nearest activation frame. +`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 @@ -3973,8 +3956,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); -- 2.7.4