Mercurial > hg > xemacs-beta

changeset 2532:989a7680c221

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-01-29 09:15:55 by ben] Add backtrace when throwing past call_trapping_problems() alloc.c, backtrace.h, bytecode.c, cmdloop.c, eval.c, lisp.h, macros.c: Also include a backtrace when we catch an attempt to throw outside of a function where call_trapping_problems() has been used.
author ben
date Sat, 29 Jan 2005 09:16:00 +0000
parents 7de8d9ab7bbd
children 0e56a4a4b77f
files src/ChangeLog src/alloc.c src/backtrace.h src/bytecode.c src/cmdloop.c src/eval.c src/lisp.h src/macros.c
diffstat 8 files changed, 76 insertions(+), 31 deletions(-) [+]
line wrap: on
line diff
--- a/src/ChangeLog	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/ChangeLog	Sat Jan 29 09:16:00 2005 +0000
@@ -1,3 +1,27 @@
+2005-01-29  Ben Wing  <ben@xemacs.org>
+
+	* alloc.c (garbage_collect_1):
+	* backtrace.h:
+	* bytecode.c (execute_rare_opcode):
+	* cmdloop.c:
+	* cmdloop.c (initial_command_loop):
+	* cmdloop.c (Frecursive_edit):
+	* cmdloop.c (call_command_loop):
+	* eval.c:
+	* eval.c (call_debugger):
+	* eval.c (Fcatch):
+	* eval.c (internal_catch):
+	* eval.c (throw_or_bomb_out):
+	* eval.c (condition_case_1):
+	* eval.c (maybe_get_trapping_problems_backtrace):
+	* eval.c (flagged_a_squirmer):
+	* eval.c (issue_call_trapping_problems_warning):
+	* eval.c (call_trapping_problems):
+	* lisp.h:
+	* macros.c (Fexecute_kbd_macro):
+	Also include a backtrace when we catch an attempt to throw outside
+	of a function where call_trapping_problems() has been used.
+
 2005-01-29  Ben Wing  <ben@xemacs.org>
 
 	* file-coding.c (snarf_coding_system):
--- a/src/alloc.c	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/alloc.c	Sat Jan 29 09:16:00 2005 +0000
@@ -4775,6 +4775,7 @@
 	mark_object (catch->tag);
 	mark_object (catch->val);
 	mark_object (catch->actual_tag);
+	mark_object (catch->backtrace);
       }
   }
 
--- a/src/backtrace.h	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/backtrace.h	Sat Jan 29 09:16:00 2005 +0000
@@ -141,6 +141,8 @@
     /* Stores the actual tag used in `throw'; the same as TAG, unless
        TAG is Vcatch_everything_tag. */
     Lisp_Object actual_tag;
+    /* A backtrace prior to the throw, used with Vcatch_everything_tag. */
+    Lisp_Object backtrace;
     Lisp_Object val;
     struct catchtag *next;
     struct gcpro *gcpro;
--- a/src/bytecode.c	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/bytecode.c	Sat Jan 29 09:16:00 2005 +0000
@@ -1377,7 +1377,7 @@
     case Bcatch:
       {
 	Lisp_Object arg = POP;
-	TOP = internal_catch (TOP, Feval, arg, 0, 0);
+	TOP = internal_catch (TOP, Feval, arg, 0, 0, 0);
 	break;
       }
 
--- a/src/cmdloop.c	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/cmdloop.c	Sat Jan 29 09:16:00 2005 +0000
@@ -1,6 +1,6 @@
 /* Editor command loop.
    Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
-   Copyright (C) 1995, 1996, 2001, 2002 Ben Wing.
+   Copyright (C) 1995, 1996, 2001, 2002, 2003 Ben Wing.
 
 This file is part of XEmacs.
 
@@ -290,7 +290,7 @@
      Otherwise, this function will return normally when all command-
      line arguments have been processed, the user's initialization
      file has been read in, and the first frame has been created. */
-  internal_catch (Qtop_level, top_level_1, Qnil, 0, 0);
+  internal_catch (Qtop_level, top_level_1, Qnil, 0, 0, 0);
 
   /* If an error occurred during startup and the initial console
      wasn't created, then die now (the error was already printed out
@@ -310,7 +310,7 @@
       MARK_MODELINE_CHANGED;
       /* Now invoke the command loop.  It never returns; however, a
 	 throw to 'top-level will place us at the end of this loop. */
-      internal_catch (Qtop_level, command_loop_2, Qnil, 0, 0);
+      internal_catch (Qtop_level, command_loop_2, Qnil, 0, 0, 0);
       /* #### wrong with selected-console? */
       /* We don't actually call clear_echo_area() here, partially
 	 at least because that runs Lisp code and it may be unsafe
@@ -373,7 +373,7 @@
   specbind (Qstandard_output, Qt);
   specbind (Qstandard_input, Qt);
 
-  val = internal_catch (Qexit, command_loop_2, Qnil, 0, 0);
+  val = internal_catch (Qexit, command_loop_2, Qnil, 0, 0, 0);
 
   if (EQ (val, Qt))
     /* Turn abort-recursive-edit into a quit. */
@@ -440,8 +440,7 @@
   if (NILP (catch_errors))
     Fcommand_loop_1 ();
   else
-    internal_catch (Qtop_level,
-                    cold_load_command_loop, Qnil, 0, 0);
+    internal_catch (Qtop_level, cold_load_command_loop, Qnil, 0, 0, 0);
   goto loop;
   RETURN_NOT_REACHED (Qnil);
 }
--- a/src/eval.c	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/eval.c	Sat Jan 29 09:16:00 2005 +0000
@@ -404,6 +404,7 @@
 #endif
 
 static int warning_will_be_discarded (Lisp_Object level);
+static Lisp_Object maybe_get_trapping_problems_backtrace (void);
 
 
 /************************************************************************/
@@ -526,7 +527,7 @@
     max_specpdl_size = specpdl_size + 40;
 
   speccount = internal_bind_int (&entering_debugger, 1);
-  val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0);
+  val = internal_catch (Qdebugger, call_debugger_259, arg, &threw, 0, 0);
 
   return unbind_to_1 (speccount, ((threw)
 				? Qunbound /* Not returning a value */
@@ -1480,7 +1481,7 @@
   /* This function can GC */
   Lisp_Object tag  = Feval (XCAR (args));
   Lisp_Object body = XCDR (args);
-  return internal_catch (tag, Fprogn, body, 0, 0);
+  return internal_catch (tag, Fprogn, body, 0, 0, 0);
 }
 
 /* Set up a catch, then call C function FUNC on argument ARG.
@@ -1492,7 +1493,8 @@
                 Lisp_Object (*func) (Lisp_Object arg),
                 Lisp_Object arg,
                 int * volatile threw,
-		Lisp_Object * volatile thrown_tag)
+		Lisp_Object * volatile thrown_tag,
+		Lisp_Object * volatile backtrace_before_throw)
 {
   /* This structure is made part of the chain `catchlist'.  */
   struct catchtag c;
@@ -1501,6 +1503,7 @@
   c.next = catchlist;
   c.tag = tag;
   c.actual_tag = Qnil;
+  c.backtrace = Qnil;
   c.val = Qnil;
   c.backlist = backtrace_list;
 #if 0 /* FSFmacs */
@@ -1521,6 +1524,7 @@
       /* Throw works by a longjmp that comes right here.  */
       if (threw) *threw = 1;
       if (thrown_tag) *thrown_tag = c.actual_tag;
+      if (backtrace_before_throw) *backtrace_before_throw = c.backtrace;
       return c.val;
     }
   c.val = (*func) (arg);
@@ -1677,6 +1681,8 @@
 #endif
       for (c = catchlist; c; c = c->next)
 	{
+	  if (EQ (c->tag, Vcatch_everything_tag))
+	    c->backtrace = maybe_get_trapping_problems_backtrace ();
 	  if (EQ (c->tag, tag) || EQ (c->tag, Vcatch_everything_tag))
 	    unwind_to_catch (c, val, tag);
 	}
@@ -1881,6 +1887,7 @@
 #endif
   c.val = Qnil;
   c.actual_tag = Qnil;
+  c.backtrace = Qnil;
   c.backlist = backtrace_list;
 #if 0 /* FSFmacs */
   /* #### */
@@ -4813,19 +4820,13 @@
   void *arg;
 };
 
-static DECLARE_DOESNT_RETURN_TYPE
-  (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object));
-
-static DOESNT_RETURN_TYPE (Lisp_Object)
-flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data,
-		    Lisp_Object opaque)
-{
-  struct call_trapping_problems *p =
-    (struct call_trapping_problems *) get_opaque_ptr (opaque);
+static Lisp_Object
+maybe_get_trapping_problems_backtrace (void)
+{
+  Lisp_Object backtrace;
 
   if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)
-      && !warning_will_be_discarded (current_warning_level ())
-      && !EQ (error_conditions, Qquit))
+      && !warning_will_be_discarded (current_warning_level ()))
     {
       struct gcpro gcpro1;
       Lisp_Object lstream = Qnil;
@@ -4842,15 +4843,32 @@
       lstream = make_resizing_buffer_output_stream ();
       Fbacktrace (lstream, Qt);
       Lstream_flush (XLSTREAM (lstream));
-      p->backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream));
+      backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream));
       Lstream_delete (XLSTREAM (lstream));
       UNGCPRO;
 
       unbind_to (speccount);
     }
   else
+    backtrace = Qnil;
+
+  return backtrace;
+}
+
+static DECLARE_DOESNT_RETURN_TYPE
+  (Lisp_Object, flagged_a_squirmer (Lisp_Object, Lisp_Object, Lisp_Object));
+
+static DOESNT_RETURN_TYPE (Lisp_Object)
+flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data,
+		    Lisp_Object opaque)
+{
+  struct call_trapping_problems *p =
+    (struct call_trapping_problems *) get_opaque_ptr (opaque);
+
+  if (!EQ (error_conditions, Qquit))
+    p->backtrace = maybe_get_trapping_problems_backtrace ();
+  else
     p->backtrace = Qnil;
-
   p->error_conditions = error_conditions;
   p->data = data;
 
@@ -4891,11 +4909,11 @@
 	{
 	  Lisp_Object errstr =
 	    emacs_sprintf_string_lisp
-	    ("%s: Attempt to throw outside of function "
-	     "to catch `%s' with value `%s'",
+	    ("%s: Attempt to throw outside of function:"
+	     "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s",
 	     Qnil, 3,
 	     build_msg_string (warning_string ? warning_string : "error"),
-	     p->thrown_tag, p->thrown_value);
+	     p->thrown_tag, p->thrown_value, p->backtrace);
 	  warn_when_safe_lispobj (Qerror, current_warning_level (), errstr);
 	}
       else if (p->caught_error && !EQ (p->error_conditions, Qquit))
@@ -5109,7 +5127,7 @@
   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
   struct call_trapping_problems package;
   struct call_trapping_problems_result real_problem;
-  Lisp_Object opaque, thrown_tag, tem;
+  Lisp_Object opaque, thrown_tag, tem, thrown_backtrace;
   int thrown = 0;
 
   assert (SYMBOLP (warning_class)); /* sanity-check */
@@ -5144,11 +5162,11 @@
        after printing the warning. (We print the warning in the stack
        context of the error, so we can get a backtrace.) */
     tem = internal_catch (package.catchtag, call_trapping_problems_1, opaque,
-			  &thrown, &thrown_tag);
+			  &thrown, &thrown_tag, &thrown_backtrace);
   else if (flags & INTERNAL_INHIBIT_THROWS)
     /* We skip over the first wrapper, which traps errors. */
     tem = internal_catch (package.catchtag, call_trapping_problems_2, opaque,
-			  &thrown, &thrown_tag);
+			  &thrown, &thrown_tag, &thrown_backtrace);
   else
     /* Nothing special. */
     tem = (fun) (arg);
@@ -5182,7 +5200,7 @@
       problem->caught_throw = 1;
       problem->error_conditions = Qnil;
       problem->data = Qnil;
-      problem->backtrace = Qnil;
+      problem->backtrace = thrown_backtrace;
       problem->thrown_tag = thrown_tag;
       problem->thrown_value = tem;
     }
--- a/src/lisp.h	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/lisp.h	Sat Jan 29 09:16:00 2005 +0000
@@ -4158,6 +4158,7 @@
 int proper_redisplay_wrapping_in_place (void);
 Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object),
 			    Lisp_Object, int * volatile,
+			    Lisp_Object * volatile,
 			    Lisp_Object * volatile);
 Lisp_Object condition_case_1 (Lisp_Object,
 			      Lisp_Object (*) (Lisp_Object),
--- a/src/macros.c	Sat Jan 29 09:06:40 2005 +0000
+++ b/src/macros.c	Sat Jan 29 09:16:00 2005 +0000
@@ -278,7 +278,7 @@
       executing_macro_index = 0;
       con->prefix_arg = Qnil;
       internal_catch (Qexecute_kbd_macro, call_command_loop,
-		      Qnil, 0, 0);
+		      Qnil, 0, 0, 0);
     }
   while (--repeat != 0
 	 && (STRINGP (Vexecuting_macro) ||