paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 08:00:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* retrieve backtrace when exception is raised

Browse Source 
* RaiseMaxFrameCount added to limit the number of backtraces, setting
    it to 0 disables backtraces. Default is 16
This commit is contained in:
peter 2005-01-26 17:07:10 +00:00
parent d3b559cfcc
commit a68b710efd
3 changed files with 76 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
rtl/inc/except.inc
View File

@ -125,6 +125,13 @@ Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer);
[Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}{$ifdef hascompilerproc} compilerproc; {$endif}
var
Newobj : PExceptObject;
framebufsize,
framecount : longint;
frames : PPointer;
prev_frame,
curr_frame,
caller_frame,
caller_addr : Pointer;
begin
{$ifdef excdebug}
writeln ('In PushExceptObject');
@ -142,8 +149,32 @@ begin
end;
ExceptObjectStack^.FObject:=Obj;
ExceptObjectStack^.Addr:=AnAddr;
ExceptObjectStack^.Frame:=AFrame;
ExceptObjectStack^.refcount := 0;
ExceptObjectStack^.refcount:=0;
{ Backtrace }
curr_frame:=AFrame;
prev_frame:=AFrame-1;
frames:=nil;
framebufsize:=0;
framecount:=0;
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) Do
Begin
caller_addr := get_caller_addr(curr_frame);
caller_frame := get_caller_frame(curr_frame);
if (caller_addr=nil) or
(caller_frame=nil) then
break;
if (framecount>=framebufsize) then
begin
inc(framebufsize,16);
reallocmem(frames,framebufsize*sizeof(pointer));
end;
frames[framecount]:=caller_addr;
inc(framecount);
prev_frame:=curr_frame;
curr_frame:=caller_frame;
End;
ExceptObjectStack^.framecount:=framecount;
ExceptObjectStack^.frames:=frames;
end;
{$ifdef hascompilerproc}
@ -154,9 +185,9 @@ Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); [external
Procedure DoUnHandledException;
begin
If ExceptProc<>Nil then
If ExceptObjectStack<>Nil then
TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr,ExceptObjectStack^.Frame);
If (ExceptProc<>Nil) and (ExceptObjectStack<>Nil) then
with ExceptObjectStack^ do
TExceptProc(ExceptProc)(FObject,Addr,FrameCount,Frames);
RunError(217);
end;
@ -171,7 +202,8 @@ begin
If ExceptAddrStack=Nil then
DoUnhandledException;
if (RaiseProc <> nil) and (ExceptObjectStack <> nil) then
RaiseProc(Obj, AnAddr, AFrame);
with ExceptObjectStack^ do
RaiseProc(FObject,Addr,FrameCount,Frames);
longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
end;
@ -226,6 +258,8 @@ begin
end;
hp:=ExceptObjectStack;
ExceptObjectStack:=ExceptObjectStack^.next;
if assigned(hp^.frames) then
freemem(hp^.frames);
dispose(hp);
end;
end;
@ -251,6 +285,8 @@ begin
fpc_PopSecondObjectStack:=ExceptObjectStack^.next^.FObject;
hp:=ExceptObjectStack^.next;
ExceptObjectStack^.next:=hp^.next;
if assigned(hp^.frames) then
freemem(hp^.frames);
dispose(hp);
end;
end;
@ -310,7 +346,12 @@ begin
end;
{
$Log$
Revision 1.16 2004-10-24 20:01:41 peter
Revision 1.17 2005-01-26 17:07:10 peter
* retrieve backtrace when exception is raised
* RaiseMaxFrameCount added to limit the number of backtraces, setting
it to 0 disables backtraces. Default is 16
Revision 1.16 2004/10/24 20:01:41 peter
* saveregisters calling convention is obsolete
Revision 1.15 2004/04/27 18:47:51 florian

21
rtl/inc/objpash.inc
View File

@ -200,21 +200,23 @@
{$endif HASINTF}
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
TExceptProc = Procedure (Obj : TObject; Addr : Pointer; FrameCount:Longint; Frame: PPointer);
{ Exception object stack }
PExceptObject = ^TExceptObject;
TExceptObject = record
FObject : TObject;
Addr,
Frame : pointer;
Next : PExceptObject;
refcount: Longint;
FObject : TObject;
Addr : pointer;
Next : PExceptObject;
refcount : Longint;
Framecount : Longint;
Frames : PPointer;
end;
Const
ExceptProc : TExceptProc = Nil;
RaiseProc : TExceptProc = Nil;
RaiseMaxFrameCount : Longint = 16;
Function RaiseList : PExceptObject;
@ -299,7 +301,12 @@
{
$Log$
Revision 1.24 2004-04-28 19:52:41 peter
Revision 1.25 2005-01-26 17:07:10 peter
* retrieve backtrace when exception is raised
* RaiseMaxFrameCount added to limit the number of backtraces, setting
it to 0 disables backtraces. Default is 16
Revision 1.24 2004/04/28 19:52:41 peter
* vtype changed to ptrint
Revision 1.23 2004/04/26 21:06:00 peter

22
rtl/objpas/sysutils/sysutils.inc
View File

@ -168,12 +168,13 @@
{$define STACKCHECK_WAS_ON}
{$S-}
{$endif OPT S }
Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
Var
Message : String;
{$IFDEF VIRTUALPASCAL}
stdout:text absolute output;
{$ENDIF}
i : longint;
begin
Writeln(stdout,'An unhandled exception occurred at $',HexStr(Ptrint(Addr),sizeof(PtrInt)*2),' :');
if Obj is exception then
@ -183,7 +184,12 @@ begin
end
else
Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
Writeln(stdout,'');
if (FrameCount>0) then
begin
Writeln(stdout,BackTraceStrFunc(Addr));
for i:=0 to FrameCount-1 do
Writeln(stdout,BackTraceStrFunc(Frames[i]));
end;
Halt(217);
end;
@ -457,14 +463,14 @@ end;
{ ---------------------------------------------------------------------
Diskh functions, OS independent.
---------------------------------------------------------------------}
function ForceDirectories(Const Dir: string): Boolean;
var
E: EInOutError;
ADir : String;
begin
Result:=True;
ADir:=ExcludeTrailingPathDelimiter(Dir);
@ -474,14 +480,14 @@ begin
E.ErrorCode:=3;
Raise E;
end;
if Not DirectoryExists(ADir) then
begin
if Not DirectoryExists(ADir) then
begin
Result:=ForceDirectories(ExtractFilePath(ADir));
If Result then
CreateDir(ADir);
end;
end;
end;
{
Revision 1.1 2003/10/06 21:01:06 peter