Mercurial > hg > xemacs-beta
diff src/eval.c @ 2532:989a7680c221
[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 | 3d8143fc88e1 |
children | 9f70af3ac939 |
line wrap: on
line diff
--- 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; }