9:16 a.m.
NOTE: This patch has been committed.
src/ChangeLog addition:
2005-01-29 Ben Wing <ben(a)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.
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