From 6302757b6fc664a8ef56ff8742aaf1987e58107d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Cl=C3=A9ment=20Pit--Claudel?= <address@hidden>
Date: Mon, 5 Dec 2016 00:52:14 -0500
Subject: [PATCH] New function mapbacktrace

---
 src/eval.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 57 insertions(+), 9 deletions(-)

diff --git a/src/eval.c b/src/eval.c
index 724f001..66b665e 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -3420,6 +3420,60 @@ The debugger is entered when that frame exits, if the flag is non-nil.  */)
   return flag;
 }
 
+static union specbinding *
+get_backtrace_starting_at (Lisp_Object base)
+{
+  union specbinding *pdl = backtrace_top ();
+
+  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);
+    }
+
+  return pdl;
+}
+
+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))
+    {
+      Lisp_Object flags = Qnil;
+      if (backtrace_debug_on_exit (pdl))
+        {
+          flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
+        }
+
+      if (backtrace_nargs (pdl) == UNEVALLED)
+        {
+          call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
+        }
+      else
+        {
+          Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
+          call4 (function, Qt, backtrace_function (pdl), tem, flags);
+        }
+      pdl = backtrace_next (pdl);
+    }
+
+  return Qnil;
+}
+
 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
        doc: /* Print a trace of Lisp function calls currently active.
 Output stream used is value of `standard-output'.  */)
@@ -3470,18 +3524,10 @@ Output stream used is value of `standard-output'.  */)
 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--)
@@ -3974,6 +4020,8 @@ alist of active lexical bindings.  */);
   defsubr (&Sfetch_bytecode);
   defsubr (&Sbacktrace_debug);
   defsubr (&Sbacktrace);
+  DEFSYM (QCdebug_on_exit, ":debug-on-exit");
+  defsubr (&Smapbacktrace);
   defsubr (&Sbacktrace_frame);
   defsubr (&Sbacktrace_eval);
   defsubr (&Sbacktrace__locals);
-- 
2.7.4