NOTE: This patch has been committed. src/ChangeLog addition: 2005-01-29 Ben Wing <ben(a)xemacs.org&gt; * 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. docs-misc source patch: Diff command: bash -ci "cvs-diff --show-c-function -no-changelog " Files affected: src/macros.c src/lisp.h src/eval.c src/cmdloop.c src/bytecode.c src/backtrace.h src/alloc.c cvs server: Diffing src Index: src/alloc.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/alloc.c,v retrieving revision 1.104 diff -u -p -r1.104 alloc.c --- src/alloc.c 2005/01/24 23:33:46 1.104 +++ src/alloc.c 2005/01/29 09:07:22 ＠＠ -4775,6 +4775,7 ＠＠ garbage_collect_1 (void) mark_object (catch->tag); mark_object (catch->val); mark_object (catch->actual_tag); + mark_object (catch->backtrace); } } Index: src/backtrace.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/backtrace.h,v retrieving revision 1.10 diff -u -p -r1.10 backtrace.h --- src/backtrace.h 2003/02/13 09:57:05 1.10 +++ src/backtrace.h 2005/01/29 09:07:22 ＠＠ -141,6 +141,8 ＠＠ struct catchtag /* 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; Index: src/bytecode.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/bytecode.c,v retrieving revision 1.44 diff -u -p -r1.44 bytecode.c --- src/bytecode.c 2005/01/24 23:33:47 1.44 +++ src/bytecode.c 2005/01/29 09:07:23 ＠＠ -1377,7 +1377,7 ＠＠ execute_rare_opcode (Lisp_Object *stack_ case Bcatch: { Lisp_Object arg = POP; - TOP = internal_catch (TOP, Feval, arg, 0, 0); + TOP = internal_catch (TOP, Feval, arg, 0, 0, 0); break; } Index: src/cmdloop.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/cmdloop.c,v retrieving revision 1.22 diff -u -p -r1.22 cmdloop.c --- src/cmdloop.c 2004/09/20 19:19:35 1.22 +++ src/cmdloop.c 2005/01/29 09:07:23 ＠＠ -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 ＠＠ initial_command_loop (Lisp_Object load_m 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 ＠＠ initial_command_loop (Lisp_Object load_m 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 ＠＠ Alternately, `(throw 'exit t)' makes thi 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 ＠＠ call_command_loop (Lisp_Object catch_err 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); } Index: src/eval.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/eval.c,v retrieving revision 1.85 diff -u -p -r1.85 eval.c --- src/eval.c 2005/01/24 23:33:51 1.85 +++ src/eval.c 2005/01/29 09:07:25 ＠＠ -404,6 +404,7 ＠＠ static int throw_level; #endif static int warning_will_be_discarded (Lisp_Object level); +static Lisp_Object maybe_get_trapping_problems_backtrace (void);  /************************************************************************/ ＠＠ -526,7 +527,7 ＠＠ call_debugger (Lisp_Object arg) 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 ＠＠ If a throw happens, it specifies the val /* 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 ＠＠ internal_catch (Lisp_Object tag, 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 ＠＠ internal_catch (Lisp_Object tag, 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 ＠＠ internal_catch (Lisp_Object tag, /* 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 ＠＠ throw_or_bomb_out (Lisp_Object tag, Lisp #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 ＠＠ condition_case_1 (Lisp_Object handlers, #endif c.val = Qnil; c.actual_tag = Qnil; + c.backtrace = Qnil; c.backlist = backtrace_list; #if 0 /* FSFmacs */ /* #### */ ＠＠ -4813,19 +4820,13 ＠＠ struct call_trapping_problems 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) +static Lisp_Object +maybe_get_trapping_problems_backtrace (void) { - struct call_trapping_problems *p = - (struct call_trapping_problems *) get_opaque_ptr (opaque); + 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 ＠＠ flagged_a_squirmer (Lisp_Object error_co 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 - p->backtrace = Qnil; + 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 ＠＠ issue_call_trapping_problems_warning (Li { 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 ＠＠ call_trapping_problems (Lisp_Object warn 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 ＠＠ call_trapping_problems (Lisp_Object warn 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 ＠＠ call_trapping_problems (Lisp_Object warn 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; } Index: src/lisp.h =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/lisp.h,v retrieving revision 1.120 diff -u -p -r1.120 lisp.h --- src/lisp.h 2005/01/28 02:36:25 1.120 +++ src/lisp.h 2005/01/29 09:07:26 ＠＠ -4158,6 +4158,7 ＠＠ Lisp_Object call_with_suspended_errors ( 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), Index: src/macros.c =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/src/macros.c,v retrieving revision 1.13 diff -u -p -r1.13 macros.c --- src/macros.c 2005/01/24 23:34:03 1.13 +++ src/macros.c 2005/01/29 09:07:27 ＠＠ -278,7 +278,7 ＠＠ COUNT is a repeat count, or nil for once 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) || cvs server: Diffing src/m cvs server: Diffing src/s