GDBMI debugger: more tests for LineInfo with exceptions, run error, assert

git-svn-id: trunk@56243 -

components/lazdebuggergdbmi/test/TestApps/ExceptPrg.pas

@@ -1,4 +1,4 @@
-program ExceptPrg;
+program ExceptPrg;  {$INLINE OFF}
 {$IFDEF TEST_WITH_HPLUS}
   {$H+}
 {$ELSE}
@@ -35,12 +35,78 @@ var
   end;
   {$ENDIF}
 
+  {$IFDEF TEST_EXCEPTION_AT}
+  procedure Bar;
+  begin
+    raise Exception.create('at1') at
+    get_caller_addr(get_caller_frame(get_frame)),
+    get_caller_frame(get_caller_frame(get_frame));
+  end;
+
+  procedure Bar1;
+  begin
+    Bar();
+  end;
+
+  procedure Bar2;
+  begin
+    Bar1();
+  end;
+
+  procedure BarBar;
+  begin
+    raise Exception.create('at2') at
+    get_caller_addr(get_frame),
+    get_caller_frame(get_frame);
+  end;
+
+  procedure BarBar1;
+  begin
+    BarBar();
+  end;
+
+  procedure BarBar2;
+  begin
+    BarBar1();
+  end;
+  {$ENDIF}
+
+  {$IFDEF TEST_RUNERR}
+  {$R+}
+  procedure Run;
+  var a: array of integer;
+  begin
+    SetLength(a, 2);
+    a[0] := -2;
+    a[1] := a[length(a)-a[0]];
+  end;
+
+  procedure Run1;
+  begin
+    Run();
+  end;
+  {$ENDIF}
+
+  {$IFDEF TEST_ASSERT}
+  {$C+}
+  procedure check;
+  begin
+    Assert(false, 'denied');
+  end;
+
+  procedure check1;
+  begin
+    check();
+  end;
+  {$ENDIF}
+
 begin
   {$IFnDEF TEST_NO_POINTER_VAR}
   p := nil;
   {$ENDIF}
   //foo;
 
+  {$IFnDEF TEST_SKIP_EXCEPTION_1}
   try
     {$IFnDEF TEST_NO_EXCEPTION_VAR}
     x := Exception.Create('foo');
@@ -59,8 +125,28 @@ begin
     end;
   end;
   writeln(1);
+  {$ENDIF}
+
+  {$IFDEF TEST_EXCEPTION_AT}
+  try
+  Bar2();
+  except end;
+  try
+  BarBar2();
+  except end;
+  {$ENDIF}
+
+  {$IFDEF TEST_RUNERR}
+  Run1();
+  {$ENDIF}
+
+  {$IFDEF TEST_ASSERT}
+  check1();
+  {$ENDIF}
+
   {$IFnDEF TEST_NO_EXCEPTION_TYPE}
   foo;
   {$ENDIF}
+
   writeln(2);
 end.

components/lazdebuggergdbmi/test/TestGdbmi.lpi

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="9"/>
+    <Version Value="10"/>
     <PathDelim Value="\"/>
     <General>
       <SessionStorage Value="InProjectDir"/>
@@ -12,9 +12,6 @@
     <i18n>
       <EnableI18N LFM="False"/>
     </i18n>
-    <VersionInfo>
-      <StringTable ProductVersion=""/>
-    </VersionInfo>
     <BuildModes Count="1">
       <Item1 Name="Default" Default="True"/>
     </BuildModes>
@@ -53,7 +50,6 @@
       <Unit0>
         <Filename Value="TestGdbmi.lpr"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="TestGdbmi"/>
       </Unit0>
       <Unit1>
         <Filename Value="testexception.pas"/>
@@ -124,6 +120,9 @@
         <OverflowChecks Value="True"/>
         <StackChecks Value="True"/>
       </Checks>
+      <Optimizations>
+        <OptimizationLevel Value="0"/>
+      </Optimizations>
     </CodeGeneration>
     <Linking>
       <Debugging>
@@ -132,11 +131,7 @@
       </Debugging>
     </Linking>
     <Other>
-      <CompilerMessages>
-        <UseMsgFile Value="True"/>
-      </CompilerMessages>
       <CustomOptions Value="-gt"/>
-      <CompilerPath Value="$(CompPath)"/>
     </Other>
   </CompilerOptions>
   <Debugging>

components/lazdebuggergdbmi/test/gdbmitestutils/gdbmitestutils.lpk

@@ -3,6 +3,7 @@
   <Package Version="4">
     <PathDelim Value="\"/>
     <Name Value="GdbmiTestUtils"/>
+    <Type Value="RunAndDesignTime"/>
     <Author Value="M Friebe"/>
     <CompilerOptions>
       <Version Value="11"/>
@@ -10,12 +11,11 @@
       <SearchPaths>
         <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
       </SearchPaths>
-      <Other>
+      <Linking>
-        <CompilerMessages>
+        <Debugging>
-          <MsgFileName Value=""/>
+          <DebugInfoType Value="dsDwarf2Set"/>
-        </CompilerMessages>
+        </Debugging>
-        <CompilerPath Value="$(CompPath)"/>
+      </Linking>
-      </Other>
     </CompilerOptions>
     <Description Value="Test helper units for LazDebuggerGDBMI"/>
     <License Value="GPL2"/>
@@ -39,10 +39,9 @@
       </Item4>
       <Item5>
         <Filename Value="testwatchutils.pas"/>
-        <UnitName Value="testwatchutils"/>
+        <UnitName Value="TestWatchUtils"/>
       </Item5>
     </Files>
-    <Type Value="RunAndDesignTime"/>
     <RequiredPkgs Count="3">
       <Item1>
         <PackageName Value="FPCUnitTestRunner"/>

components/lazdebuggergdbmi/test/gdbmitestutils/testbase.pas

@@ -6,7 +6,8 @@ interface
 
 uses
   Classes, SysUtils, FileUtil, fpcunit, testutils, testregistry, LCLProc, LazLogger,
-  LazFileUtils, DbgIntfDebuggerBase, CompileHelpers, Dialogs, TestGDBMIControl, GDBMIDebugger; // , FpGdbmiDebugger;
+  LazFileUtils, DbgIntfDebuggerBase, CompileHelpers, Dialogs, TestGDBMIControl,
+  RegExpr, GDBMIDebugger; // , FpGdbmiDebugger;
   // EnvironmentOpts, ExtToolDialog, TransferMacros,
 
 (*
@@ -375,6 +376,10 @@ type
     procedure AddTestSuccess(s: string; MinGdbVers: Integer = 0; AIgnoreReason: String = '');
     procedure AddTestSuccess(s: string; MinGdbVers: Integer; MinFpcVers: Integer;AIgnoreReason: String = '');
 
+    function TestMatches(Expected, Got: string): Boolean;
+    function TestMatches(Name: string; Expected, Got: string; MinGdbVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
+    function TestMatches(Name: string; Expected, Got: string; MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
+
     function TestEquals(Expected, Got: string): Boolean;
     function TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer = 0; AIgnoreReason: String = ''): Boolean;
     function TestEquals(Name: string; Expected, Got: string; MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String = ''): Boolean;
@@ -1066,6 +1071,32 @@ begin
     inc(FSucessCnt);
 end;
 
+function TGDBTestCase.TestMatches(Expected, Got: string): Boolean;
+begin
+  Result := TestMatches('', Expected, Got);
+end;
+
+function TGDBTestCase.TestMatches(Name: string; Expected, Got: string;
+  MinGdbVers: Integer; AIgnoreReason: String): Boolean;
+begin
+  Result := TestMatches(Name, Expected, Got, MinGdbVers, 0, AIgnoreReason);
+end;
+
+function TGDBTestCase.TestMatches(Name: string; Expected, Got: string;
+  MinGdbVers: Integer; MinFpcVers: Integer; AIgnoreReason: String): Boolean;
+var
+  rx: TRegExpr;
+begin
+  rx := TRegExpr.Create;
+  rx.ModifierI := true;
+  rx.Expression := Expected;
+  Result :=  rx.Exec(Got);
+  FreeAndNil(rx);
+  if Result
+  then AddTestSuccess(Name + ': Expected to fail with, but succeded, Got "'+Got+'"', MinGdbVers, MinFpcVers, AIgnoreReason)
+  else AddTestError(Name + ': Expected "'+Expected+'", Got "'+Got+'"', MinGdbVers, MinFpcVers, AIgnoreReason);
+end;
+
 function TGDBTestCase.TestEquals(Expected, Got: string): Boolean;
 begin
   Result := TestEquals('', Expected, Got);

components/lazdebuggergdbmi/test/testexception.pas

@@ -21,6 +21,7 @@ type
     FGotExceptClass: String;
     FGotExceptMsg: String;
     FGotExceptType: TDBGExceptionType;
+    FGotExceptionLocation: TDBGLocationRec;
 
     procedure DoDebuggerException(Sender: TObject;
                                   const AExceptionType: TDBGExceptionType;
@@ -61,6 +62,7 @@ begin
   FGotExceptClass := AExceptionClass;
   FGotExceptMsg   := AExceptionText;
   FGotExceptType  := AExceptionType;
+  FGotExceptionLocation := AExceptionLocation;
   AContinue := False;
 end;
 
@@ -77,26 +79,106 @@ var
 begin
   if SkipTest then exit;
   if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
+  if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('  TTestException')] then exit;
   ClearTestErrors;
 
-  TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '', '-gt -gh');
+  TstName := 'All';
+  TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_raise_at', '-gt -gh -dTEST_EXCEPTION_AT');
   try
-    FGotExceptCount := 0; TstName := 'all';
+    FGotExceptCount := 0;
     dbg := StartGDB(AppDir, TestExeName);
     dbg.OnException      := @DoDebuggerException;
 
     dbg.Run;
+    TstName := 'All - raise';
     TestEquals(TstName+' Got 1 exception',   1, FGotExceptCount);
     TestEquals(TstName+' Got class',         'Exception', FGotExceptClass);
     TestEquals(TstName+' Got msg',           'foo', FGotExceptMsg, 060000);
+    TestEquals(TstName+' Got location Line',  113, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+    TestMatches(TstName+' Got location Proc', '^main$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deInternal);
+
     dbg.Run;
-    TestEquals(TstName+' Got 2nd exception', 2, FGotExceptCount);
+    TstName := 'All - raise at 2 down';
+    TestEquals(TstName+' Got exception 2', 2, FGotExceptCount);
+    TestEquals(TstName+' Got class', 'Exception', FGotExceptClass);
+    TestEquals(TstName+' Got msg',   'at1', FGotExceptMsg, 060000);
+    TestEquals(TstName+' Got location Line',  53, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+    TestMatches(TstName+' Got location Proc', '^Bar2$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deInternal);
+
     dbg.Run;
-    TestEquals(TstName+' Got no more exception', 2, FGotExceptCount);
+    TstName := 'All - raise at 1 down';
+    TestEquals(TstName+' Got exception 3', 3, FGotExceptCount);
+    TestEquals(TstName+' Got class', 'Exception', FGotExceptClass);
+    TestEquals(TstName+' Got msg',   'at2', FGotExceptMsg, 060000);
+    TestEquals(TstName+' Got location Line',  65, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+    TestMatches(TstName+' Got location Proc', '^BarBar1$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deInternal);
+
+    dbg.Run;
+    TstName := 'All - raise subclass';
+    TestEquals(TstName+'Got exception 4', 4, FGotExceptCount);
     TestEquals(TstName+' Got class', 'MyESome', FGotExceptClass);
     // not yet MakePrintable
     //TestEquals(TstName+' Got msg',   'abc üü {[''''[{ \n\t''#13#9''#', FGotExceptMsg, 050300);
     TestEquals(TstName+' Got msg',   'abc üü {[''[{ \n\t'#13#9'#', FGotExceptMsg, 050300);
+    TestEquals(TstName+' Got location Line',  34, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+    TestMatches(TstName+' Got location Proc', '^foo$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deInternal);
+
+    dbg.Run;
+    TestEquals(TstName+' Got no more exception', 4, FGotExceptCount);
+    dbg.Stop;
+  finally
+    dbg.Done;
+    CleanGdb;
+    dbg.Free;
+  end;
+
+  TstName := 'RunError';
+  TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_runerr', '-gt -gh -dTEST_SKIP_EXCEPTION_1 -dTEST_RUNERR');
+  try
+    FGotExceptCount := 0;
+    dbg := StartGDB(AppDir, TestExeName);
+    dbg.OnException      := @DoDebuggerException;
+
+    dbg.Run;
+    TestEquals(TstName+' Got run err', 1, FGotExceptCount);
+    TestMatches(TstName+' Got class', 'RunError', FGotExceptClass);
+    //TestEquals(TstName+' Got msg',   'at2', FGotExceptMsg, 060000);
+    TestEquals(TstName+' Got location Line',  81, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+    TestMatches(TstName+' Got location Proc', '^Run$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deRunError);
+
+    dbg.Stop;
+  finally
+    dbg.Done;
+    CleanGdb;
+    dbg.Free;
+  end;
+
+  TstName := 'Assert';
+  TestCompile(AppDir + 'ExceptPrg.pas', TestExeName, '_assert', '-gt -gh -dTEST_SKIP_EXCEPTION_1 -dTEST_ASSERT');
+  try
+    FGotExceptCount := 0;
+    dbg := StartGDB(AppDir, TestExeName);
+    dbg.OnException      := @DoDebuggerException;
+
+    dbg.Run;
+    TestEquals(TstName+' Got Assert', 1, FGotExceptCount);
+    TestMatches(TstName+' Got class', 'EAssertionFailed', FGotExceptClass);
+    TestMatches(TstName+' Got msg',   'denied', FGotExceptMsg, 060000);
+//    TestEquals(TstName+' Got location Line',  94, FGotExceptionLocation.SrcLine);
+    TestMatches(TstName+' Got location File', 'ExceptPrg\.pas$', FGotExceptionLocation.SrcFile);
+//    TestMatches(TstName+' Got location Proc', '^check$', FGotExceptionLocation.FuncName);
+    TestTrue(TstName+' Got type', FGotExceptType = deInternal);
+
     dbg.Stop;
   finally
     dbg.Done;
@@ -243,6 +325,7 @@ var
 begin
   if SkipTest then exit;
   if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestExceptionOne')] then exit;
+  if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('  TTestExceptionStepOut')] then exit;
   ClearTestErrors;
 
   TestCompile(AppDir + 'ExceptPrgStep.pas', TestExeName, '', '');
@@ -289,7 +372,7 @@ end;
 
 initialization
   RegisterDbgTest(TTestExceptionOne);
-  RegisterTestSelectors(['TTestExceptionOne'
+  RegisterTestSelectors(['TTestExceptionOne', '  TTestException', '  TTestExceptionStepOut'
                         ]);
 
 end.