paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 07:38:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

Introduces the define DEBUG_ALLOW_DUMPBACKTRACE which removes code to dump a backtrace to the console, which crashes WinCE applications. Fixed bug #15075

Browse Source 
git-svn-id: trunk@22722 -
This commit is contained in:
sekelsenmat 2009-11-23 13:51:52 +00:00
parent c91bb602d6
commit 2774606c92
4 changed files with 12 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lcl/forms.pp
View File

@ -1584,6 +1584,7 @@ Begin
DebugLn('[FORMS.PP] ExceptionOccurred ');
if HaltingProgram or HandlingException then Halt;
HandlingException:=true;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
if Sender<>nil then begin
DebugLn(' Sender=',Sender.ClassName);
if Sender is Exception then begin
@ -1595,6 +1596,7 @@ Begin
end;
end else
DebugLn(' Sender=nil');
{$endif}
if Application<>nil then
Application.HandleException(Sender);
HandlingException:=false;

4
lcl/include/application.inc
View File

@ -1073,7 +1073,9 @@ begin
DebugLn('TApplication.HandleException: ',
'there was another exception during showing the first exception');
HaltingProgram:=true;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
DumpExceptionBackTrace;
{$endif}
Halt;
end;
Include(FFlags,AppHandlingException);
@ -1083,6 +1085,7 @@ begin
Skip := ExceptObject is EAbort;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
if not (AppNoExceptionMessages in FFlags) then
begin
// before we do anything, write it down
@ -1099,6 +1102,7 @@ begin
DumpExceptionBackTrace;
end;
end;
{$endif}
// release capture and hide all forms with stay on top, so that
// a message can be shown
if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0);

4
lcl/lclproc.pas
View File

@ -183,7 +183,9 @@ function StrToDouble(const s: string): double;
// debugging
procedure RaiseGDBException(const Msg: string);
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
procedure DumpExceptionBackTrace;
{$endif}
procedure DumpStack;
function GetStackTrace(UseCache: boolean): string;
procedure GetStackTracePointers(var AStack: TStackTracePointers);
@ -1504,6 +1506,7 @@ begin
if (length(Msg) div (length(Msg) div 10000))=0 then ;
end;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
procedure DumpExceptionBackTrace;
var
FrameCount: integer;
@ -1517,6 +1520,7 @@ begin
for FrameNumber := 0 to FrameCount-1 do
DebugLn(BackTraceStrFunc(Frames[FrameNumber]));
end;
{$endif}
procedure DumpStack;
begin

2
lcl/translations.pas
View File

@ -404,11 +404,13 @@ begin
{$endif ver2_0}
Result:=true;
except
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
on e: Exception do begin
DebugLn('Exception while translating ', ResUnitName);
DebugLn(e.Message);
DumpExceptionBackTrace;
end;
{$endif}
end;
end;