* retrieve backtrace when exception is raised

  * RaiseMaxFrameCount added to limit the number of backtraces, setting
    it to 0 disables backtraces. Default is 16

rtl/inc/except.inc

@@ -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

rtl/inc/objpash.inc

@@ -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

rtl/objpas/sysutils/sysutils.inc

@@ -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