diff --git a/.gitattributes b/.gitattributes index 14e9c64c23..eab8572c21 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2789,6 +2789,7 @@ debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc svneol=native#text/pascal debugger/test/Gdbmi/TestApps/WatchesPrgString.inc svneol=native#text/pascal debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc svneol=native#text/pascal debugger/test/Gdbmi/TestApps/WatchesPrgVariant.inc svneol=native#text/pascal +debugger/test/Gdbmi/TestApps/u1/unitw1.pas svneol=native#text/pascal debugger/test/Gdbmi/TestGdbmi.lpi svneol=native#text/pascal debugger/test/Gdbmi/TestGdbmi.lpr svneol=native#text/pascal debugger/test/Gdbmi/compilehelpers.pas svneol=native#text/pascal diff --git a/debugger/test/Gdbmi/TestApps/WatchesPrg.pas b/debugger/test/Gdbmi/TestApps/WatchesPrg.pas index 78ced459a2..192d2e316a 100644 --- a/debugger/test/Gdbmi/TestApps/WatchesPrg.pas +++ b/debugger/test/Gdbmi/TestApps/WatchesPrg.pas @@ -1,21 +1,36 @@ +// Do not add/remove lines +// TestWatches.pas expects hardcoded lines for breakpoints + (* Struture program WatchesPrg; + type - {$DEFINE Global_Types} - {$DEFINE Global_Implementation} + {$DEFINE Global_Types} + + {$DEFINE Global_Implementation} procedure FooFunc( {$DEFINE FooFunc_Param} } type {$DEFINE FooFunc_LocalType} var {$DEFINE FooFunc_Local} - function SubFoo()():Integer; begin end; - begin - {$DEFINE FooFunc_Body} - end; + + function SubFoo()():Integer; + type + {$DEFINE SubFooFunc_LocalType} + var + {$DEFINE SubFooFunc_Local} + begin + {$DEFINE SubFooFunc_Body} + end; + + begin + {$DEFINE FooFunc_Body} + end; var {$DEFINE Global_Var} + begin {$DEFINE Global_Body} FooFunc( {$DEFINE Global_Call_FooFunc} ); @@ -28,7 +43,7 @@ program WatchesPrg; {$H-} -uses sysutils, variants, Classes; +uses sysutils, variants, Classes {$IFDEF USE_W1} , unitw1 {$ENDIF}; type {$DEFINE Global_Types} @@ -132,7 +147,62 @@ var {$UNDEF FooFunc_Local} function SubFoo(var AVal1: Integer; AVal2: Integer) : Integer; + type + (*** local type ***) + {$DEFINE SubFooFunc_LocalType} + { class/record/object } + {$I WatchesPrgStruct.inc} + { strings } + {$I WatchesPrgString.inc} + { simple } + {$I WatchesPrgSimple.inc} + { enum/set } + {$I WatchesPrgEnum.inc} + { Array } + {$I WatchesPrgArray.inc} + { variants } + {$I WatchesPrgVariant.inc} + { procedure/function/method } + {$I WatchesPrgProc.inc} + DummySubFooType12345 = Integer; + {$UNDEF SubFooFunc_LocalType} + + var + (*** local var ***) + {$DEFINE SubFooFunc_Local} + { class/record/object } + {$I WatchesPrgStruct.inc} + { strings } + {$I WatchesPrgString.inc} + { simple } + {$I WatchesPrgSimple.inc} + { enum/set } + {$I WatchesPrgEnum.inc} + { Array } + {$I WatchesPrgArray.inc} + { variants } + {$I WatchesPrgVariant.inc} + { procedure/function/method } + {$I WatchesPrgProc.inc} + DummySubFooVar12345: Integer; + {$UNDEF SubFooFunc_Local} begin + {$DEFINE SubFooFunc_Body} + { class/record/object } + {$I WatchesPrgStruct.inc} + { strings } + {$I WatchesPrgString.inc} + { simple } + {$I WatchesPrgSimple.inc} + { enum/set } + {$I WatchesPrgEnum.inc} + { Array } + {$I WatchesPrgArray.inc} + { variants } + {$I WatchesPrgVariant.inc} + { procedure/function/method } + {$I WatchesPrgProc.inc} + {$UNDEF SubFooFunc_Body} writeln(1); // nested break end; diff --git a/debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc b/debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc index 1324dfa23e..89bcee52fd 100644 --- a/debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc +++ b/debugger/test/Gdbmi/TestApps/WatchesPrgSimple.inc @@ -1,4 +1,54 @@ +{* ******************** CACHE-TEST ******************** *} +{%region CACHE-TEST} + {%region TYPE} + {$IFDEF Global_Types} + TCacheTestType = class + public + CTVal: Integer; + end; + {$ENDIF} + + {$IFDEF SubFooFunc_LocalType} + TCacheTest = record + CTVal: Integer; + end; + {$ENDIF} + + {$IFDEF FooFunc_LocalType} + TCacheTest = TCacheTestType; + {$ENDIF} + {%endregion TYPE} + + {%region VARIABLES} + {$IFDEF SubFooFunc_Local} + VarCacheTest1: TCacheTest; // record + VarCacheTest2: Integer; + {$ENDIF} + + {$IFDEF FooFunc_Local} + VarCacheTest1: TCacheTest; // class + VarCacheTest2: Integer; + {$ENDIF} + {%endregion VARIABLES} + + {%region CODE (initilization)} + {$IFDEF SubFooFunc_Body} + VarCacheTest1.CTVal := 101; + VarCacheTest2 := 102; + {$ENDIF} + + {$IFDEF FooFunc_Body} + VarCacheTest1 := TCacheTest.Create; + VarCacheTest1.CTVal := 201; + VarCacheTest2 := 202; + {$ENDIF} + {%endregion CODE (initilization)} + +{%endregion CACHE-TEST} + +{* ******************** -- ******************** *} + {%region FooFunc} {$IFDEF FooFunc_Param} //procedure FooFunc( diff --git a/debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc b/debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc index 02b9327f07..183f9cf1a5 100644 --- a/debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc +++ b/debugger/test/Gdbmi/TestApps/WatchesPrgStruct.inc @@ -33,6 +33,7 @@ {$ENDIF} +{* ******************** RECORD ******************** *} {%region RECORD} {%region TYPE} @@ -174,7 +175,171 @@ {%endregion RECORD} +{* ******************** CLASSES ******************** *} +{%region CLASSES} + {%region TYPE} + {$IFDEF Global_Types} + //type + { Classes } + TFooComp = class(TComponent) + public + ValueInt: Integer; + end; + + {$IFDEF USE_W1} + TFooCompOtherBase = class(TFooTestTestBase) + {$ELSE} + TFooCompOtherBase = class(TObject) + {$ENDIF} + public + ValueInt: Integer; + end; + + { TFoo } + + TFoo = class + private + function GetValueInt: Integer; + procedure SetValueInt(AValue: Integer); + public + ValueInt: Integer; + ValueFoo: TFoo; + ValueRec: TRec; + FooText: string[20]; + FooString: String; + FooChar: Char; + property PropInt: Integer read ValueInt write ValueInt; + property PropIntGS: Integer read GetValueInt write SetValueInt; + end; + + TFooChild = class(TFoo) end; + TFooKid = class(TFoo) end; + + PFoo = ^TFoo; + PPFoo = ^PFoo; + TSamePFoo = PFoo; + TNewPFoo = {type} PFoo; // fpc crash + + TSameFoo = TFoo; + TNewFoo = type TFoo; + PNewFoo = ^TNewFoo; + {$ENDIF} + + {$IFDEF FooFunc_LocalType} + //type + {$ENDIF} + {%endregion TYPE} + + {%region VARIABLES} + {$IFDEF FooFunc_Param} + {$ENDIF} + {$IFDEF Global_Call_FooFunc} + //FooFunc( + { Classes } + GlobTFoo, GlobTFoo, + GlobPFoo, GlobPFoo, + GlobPPFoo, GlobPPFoo, + GlobTSamePFoo, GlobTSamePFoo, + GlobTNewPFoo, GlobTNewPFoo, + + GlobTSameFoo, GlobTSameFoo, + GlobTNewFoo, GlobTNewFoo, + GlobPNewFoo, GlobPNewFoo, + {$ENDIF} + + {$IFDEF FooFunc_Local} + //var + {$ENDIF} + + {$IFDEF Global_Var} + //var + { Classes } + GlobTFoo, GlobTFoo1, GlobTFoo2, GlobTFooNil: TFoo; + GlobPFoo: PFoo; + GlobPPFoo: PPFoo; + GlobTSamePFoo: TSamePFoo; + GlobTNewPFoo: TNewPFoo; + + GlobTSameFoo: TSameFoo; + GlobTNewFoo: TNewFoo; + GlobPNewFoo: PNewFoo; + + PGlobTFoo: ^TFoo; + PGlobPFoo: ^PFoo; + PGlobTSamePFoo: ^TSamePFoo; + PGlobTSameFoo: ^TSameFoo; + {$ENDIF} + + {$IFDEF Global_Implementation} + { TFoo } + + function TFoo.GetValueInt: Integer; + begin + Result := PropInt; + end; + + procedure TFoo.SetValueInt(AValue: Integer); + begin + PropInt := AValue; + end; + {$ENDIF} + {%endregion VARIABLES} + + {%region CODE (initilization)} + {$IFDEF FooFunc_Body} + //begin + {$ENDIF} + + {$IFDEF Global_Body} + //begin + { Classes } + GlobTFoo := TFoo.Create; + GlobTFoo.ValueInt := -11; + GlobTFoo.FooText := 'mem of TFoo '' "'; + GlobTFoo.FooString := 'a 1 \ " '' '#9'...'; + GlobTFoo.FooChar := '\'; + GlobTFoo1 := TFoo.Create; + GlobTFoo1.ValueInt := 31; + GlobTFoo2 := TFoo.Create; + GlobTFoo2.ValueInt := 32; + GlobTFooNil := nil; + GlobPFoo := @GlobTFoo1; + GlobPPFoo := @GlobPFoo; + GlobTSamePFoo := @GlobTFoo2; + GlobTNewPFoo := @GlobTFoo; + + GlobTSameFoo := TFoo.Create; + GlobTSameFoo.ValueInt := 41; + GlobTNewFoo := TNewFoo.Create; + GlobTNewFoo.ValueInt := 42; + GlobPNewFoo := @GlobTSameFoo; + + PGlobTFoo := @GlobTFoo; + PGlobPFoo := @PGlobTFoo; + PGlobTSamePFoo := @GlobTFoo; + PGlobTSameFoo := @GlobTFoo; + {$ENDIF} + + {$IFDEF Global_Body_NIL} + //begin + { Classes } + GlobTFoo := nil; + GlobPFoo := nil; + GlobPPFoo := nil; + GlobTSamePFoo := nil; + GlobTNewPFoo := nil; + + GlobTSameFoo := nil; + GlobTNewFoo := nil; + GlobPNewFoo := nil; + {$ENDIF} + + {%endregion CODE (initilization)} +{%endregion CLASSES} + + +{* ******************** CLASSTYPES ******************** *} {%region FooFunc} {$IFDEF FooFunc_Param} @@ -225,7 +390,8 @@ PVarTFooClass: ^TFooClass; - VarFooComp, VarFooComp1: TFooComp; + VarFooComp, VarFooComp1: TObject; // TFooComp; + VarFooOther, VarFooOther1: TObject; // TFooCompOtherBase; { OBJECT } VarOldObject: TOldObject; @@ -262,48 +428,16 @@ VarOldObject.OldVal := 1; VarFooComp := TFooComp.Create(nil); - VarFooComp := nil; + VarFooComp1 := nil; + + VarFooOther := TFooCompOtherBase.Create; + VarFooOther1 := nil; {$ENDIF} {%endregion FooFunc} + {%region GLOBAL} {$IFDEF Global_Types} - { Classes } - - TFooComp = class(TComponent) - public - ValueInt: Integer; - end; - - { TFoo } - - TFoo = class - private - function GetValueInt: Integer; - procedure SetValueInt(AValue: Integer); - public - ValueInt: Integer; - ValueFoo: TFoo; - ValueRec: TRec; - FooText: string[20]; - FooString: String; - FooChar: Char; - property PropInt: Integer read ValueInt write ValueInt; - property PropIntGS: Integer read GetValueInt write SetValueInt; - end; - - TFooChild = class(TFoo) end; - TFooKid = class(TFoo) end; - - PFoo = ^TFoo; - PPFoo = ^PFoo; - TSamePFoo = PFoo; - TNewPFoo = {type} PFoo; // fpc crash - - TSameFoo = TFoo; - TNewFoo = type TFoo; - PNewFoo = ^TNewFoo; - { ClassesTypes } TFooClass = Class of TFoo; PFooClass = ^TFooClass; @@ -319,37 +453,6 @@ {$ENDIF} {$IFDEF Global_Var} - { TFoo } - - function TFoo.GetValueInt: Integer; - begin - Result := PropInt; - end; - - procedure TFoo.SetValueInt(AValue: Integer); - begin - PropInt := AValue; - end; - - var - - //var - { Classes } - GlobTFoo, GlobTFoo1, GlobTFoo2, GlobTFooNil: TFoo; - GlobPFoo: PFoo; - GlobPPFoo: PPFoo; - GlobTSamePFoo: TSamePFoo; - GlobTNewPFoo: TNewPFoo; - - GlobTSameFoo: TSameFoo; - GlobTNewFoo: TNewFoo; - GlobPNewFoo: PNewFoo; - - PGlobTFoo: ^TFoo; - PGlobPFoo: ^PFoo; - PGlobTSamePFoo: ^TSamePFoo; - PGlobTSameFoo: ^TSameFoo; - { ClassesTyps } GlobTFooClass: TFooClass; GlobPFooClass: PFooClass; @@ -362,33 +465,6 @@ {$IFDEF Global_Body} //begin - { Classes } - GlobTFoo := TFoo.Create; - GlobTFoo.ValueInt := -11; - GlobTFoo.FooText := 'mem of TFoo '' "'; - GlobTFoo.FooString := 'a 1 \ " '' '#9'...'; - GlobTFoo.FooChar := '\'; - GlobTFoo1 := TFoo.Create; - GlobTFoo1.ValueInt := 31; - GlobTFoo2 := TFoo.Create; - GlobTFoo2.ValueInt := 32; - GlobTFooNil := nil; - GlobPFoo := @GlobTFoo1; - GlobPPFoo := @GlobPFoo; - GlobTSamePFoo := @GlobTFoo2; - GlobTNewPFoo := @GlobTFoo; - - GlobTSameFoo := TFoo.Create; - GlobTSameFoo.ValueInt := 41; - GlobTNewFoo := TNewFoo.Create; - GlobTNewFoo.ValueInt := 42; - GlobPNewFoo := @GlobTSameFoo; - - PGlobTFoo := @GlobTFoo; - PGlobPFoo := @PGlobTFoo; - PGlobTSamePFoo := @GlobTFoo; - PGlobTSameFoo := @GlobTFoo; - { ClassesTyps } GlobTFooClass := TFooKid; GlobPFooClass := @GlobTFooClass; @@ -401,17 +477,6 @@ {$IFDEF Global_Body_NIL} //begin - { Classes } - GlobTFoo := nil; - GlobPFoo := nil; - GlobPPFoo := nil; - GlobTSamePFoo := nil; - GlobTNewPFoo := nil; - - GlobTSameFoo := nil; - GlobTNewFoo := nil; - GlobPNewFoo := nil; - { ClassesTyps } GlobTFooClass := nil; GlobPFooClass := nil; @@ -422,17 +487,6 @@ {$IFDEF Global_Call_FooFunc} //FooFunc( - { Classes } - GlobTFoo, GlobTFoo, - GlobPFoo, GlobPFoo, - GlobPPFoo, GlobPPFoo, - GlobTSamePFoo, GlobTSamePFoo, - GlobTNewPFoo, GlobTNewPFoo, - - GlobTSameFoo, GlobTSameFoo, - GlobTNewFoo, GlobTNewFoo, - GlobPNewFoo, GlobPNewFoo, - { ClassesTyps } GlobTFooClass, GlobTFooClass, GlobPFooClass, GlobPFooClass, diff --git a/debugger/test/Gdbmi/TestApps/u1/unitw1.pas b/debugger/test/Gdbmi/TestApps/u1/unitw1.pas new file mode 100644 index 0000000000..f965555e30 --- /dev/null +++ b/debugger/test/Gdbmi/TestApps/u1/unitw1.pas @@ -0,0 +1,14 @@ +unit unitw1; + +{$mode objfpc}{$H+} + +interface + +type + TFooTestTestBase = class + a: integer; + end; + +implementation + +end. diff --git a/debugger/test/Gdbmi/testbase.pas b/debugger/test/Gdbmi/testbase.pas index 005eb02a28..10bc11362d 100644 --- a/debugger/test/Gdbmi/testbase.pas +++ b/debugger/test/Gdbmi/testbase.pas @@ -51,7 +51,7 @@ type end; TUsesDir = record - DirName: String; + DirName, ExeId: String; // dirname = filename SymbolType: TSymbolType; ExtraOpts, NamePostFix: string; end; @@ -117,7 +117,7 @@ type FSymbolSwitch: String; FSymbolType: TSymbolType; FFileNameExt: String; - FCompiledList: TStringList; + FCompiledList, FCompiledUsesList, FCompiledUsesListID: TStringList; FInRun: Boolean; protected procedure Clear; @@ -127,7 +127,7 @@ type procedure Run(AResult: TTestResult); override; procedure RunTest(ATest: TTest; AResult: TTestResult); override; procedure RegisterDbgTest(ATestClass: TTestCaseClass); - Procedure TestCompileUses(UsesDir: TUsesDir; out UsesLibDir); + procedure TestCompileUses(UsesDir: TUsesDir; out UsesLibDir: String; out ExeID:string); Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String='' @@ -154,7 +154,7 @@ type public constructor Create(AParent: TCompilerSuite; ADebuggerInfo: TDebuggerInfo); procedure RegisterDbgTest(ATestClass: TTestCaseClass); - Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); + Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String=''); public property Parent: TCompilerSuite read FParent; property DebuggerInfo: TDebuggerInfo read FDebuggerInfo; @@ -173,7 +173,7 @@ type public constructor Create(AParent: TDebuggerSuite; AClass: TClass); procedure AddTest(ATest: TTest); overload; override; - Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); + Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String=''); public property Parent: TDebuggerSuite read FParent; property DebuggerInfo: TDebuggerInfo read GetDebuggerInfo; @@ -202,6 +202,7 @@ type FRegisters: TIDERegisters; private FParent: TGDBTestsuite; + FTestBaseName: String; FTestResult: TGDBTestResult; FTestErrors, FIgnoredErrors, FUnexpectedSuccess: String; FTestCnt, FTestErrorCnt, FIgnoredErrorCnt, FUnexpectedSuccessCnt, FSucessCnt: Integer; @@ -232,12 +233,15 @@ type procedure AssertTestErrors; property TestErrors: string read FTestErrors; public - Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); + Procedure TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); overload; + Procedure TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; + NamePostFix: String=''; ExtraArgs: String=''); overload; public property Parent: TGDBTestsuite read FParent write FParent; property DebuggerInfo: TDebuggerInfo read GetDebuggerInfo; property SymbolType: TSymbolType read GetSymbolType; property CompilerInfo: TCompilerInfo read GetCompilerInfo; + property TestBaseName: String read FTestBaseName write FTestBaseName; public //property BreakPoints: TIDEBreakPoints read FBreakpoints; // A list of breakpoints for the current project //property BreakPointGroups: TIDEBreakPointGroups read FBreakPointGroups; @@ -290,6 +294,21 @@ begin end; end; +function NameToFileName(AName: String): String; +var + i: Integer; +begin + Result := ''; + for i := 1 to length(AName) do begin + if AName[i] in ['a'..'z', 'A'..'Z', '0'..'9', '.', '-'] then + Result := Result + AName[i] + else if AName[i] = ' ' then + Result := Result + '__' + else + Result := Result + '_' + IntToHex(ord(AName[i]), 2); + end; +end; + function GetCompilers: TCompilerList; begin @@ -371,9 +390,9 @@ var begin if GetLogActive then begin name := TestName - + '_' + GetCompilerInfo.Name + + '_' + NameToFileName(GetCompilerInfo.Name) + '_' + SymbolTypeNames[GetSymbolType] - + '_' + GetDebuggerInfo.Name + + '_' + NameToFileName(GetDebuggerInfo.Name) + '.log'; dir := ConfDir; if DirectoryExistsUTF8(Logdir) then @@ -470,6 +489,7 @@ begin FUnexpectedSuccessCnt := 0; FSucessCnt := 0; FTestCnt := 0; + FTestBaseName := ''; end; procedure TGDBTestCase.AddTestError(s: string; MinGdbVers: Integer = 0); @@ -479,6 +499,7 @@ var begin inc(FTestCnt); IgnoreReason := ''; + s := FTestBaseName + s; if MinGdbVers > 0 then begin i := GetDebuggerInfo.Version; if (i > 0) and (i < MinGdbVers) then @@ -497,6 +518,7 @@ procedure TGDBTestCase.AddTestSuccess(s: string; MinGdbVers: Integer); var i: Integer; begin + s := FTestBaseName + s; inc(FTestCnt); if MinGdbVers > 0 then begin i := GetDebuggerInfo.Version; @@ -577,11 +599,17 @@ end; procedure TGDBTestCase.TestCompile(const PrgName: string; out ExeName: string; NamePostFix: String=''; ExtraArgs: String=''); +begin + TestCompile(PrgName, ExeName, [], NamePostFix, ExtraArgs); +end; + +procedure TGDBTestCase.TestCompile(const PrgName: string; out ExeName: string; + UsesDirs: array of TUsesDir; NamePostFix: String; ExtraArgs: String); begin if GetLogActive then begin writeln(FLogFile, LineEnding+LineEnding+'******************* compile '+PrgName + ' ' + ExtraArgs +LineEnding); end; - Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs); + Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs); FCurrentPrgName := PrgName; FCurrentExename := ExeName; end; @@ -739,7 +767,11 @@ var begin for i := 0 to FCompiledList.Count - 1 do DeleteFile(FCompiledList[i]); + for i := 0 to FCompiledUsesList.Count - 1 do + DeleteDirectory(FCompiledUsesList[i], False); FCompiledList.Clear; + FCompiledUsesList.Clear; + FCompiledUsesListID.Clear; end; constructor TCompilerSuite.Create(ACompilerInfo: TCompilerInfo; ASymbolType: TSymbolType; @@ -753,18 +785,12 @@ begin FSymbolType := ASymbolType; FCompiledList := TStringList.Create; + FCompiledUsesList := TStringList.Create; + FCompiledUsesListID := TStringList.Create; FSymbolSwitch := SymbolTypeSwitches[FSymbolType]; FInRun := False; - FFileNameExt := SymbolTypeNames[FSymbolType] + '_'; - for i := 1 to length(CompilerInfo.Name) do begin - if CompilerInfo.Name[i] in ['a'..'z', 'A'..'Z', '0'..'9', '.', '-'] then - FFileNameExt := FFileNameExt + CompilerInfo.Name[i] - else if CompilerInfo.Name[i] = ' ' then - FFileNameExt := FFileNameExt + '__' - else - FFileNameExt := FFileNameExt + '_' + IntToHex(ord(CompilerInfo.Name[i]), 2); - end; + FFileNameExt := SymbolTypeNames[FSymbolType] + '_' + NameToFileName(CompilerInfo.Name); for i := 0 to ADebuggerList.Count - 1 do begin if not (FSymbolType in ADebuggerList.SymbolTypes[i]) then @@ -779,6 +805,8 @@ begin inherited Destroy; Clear; FreeAndNil(FCompiledList); + FreeAndNil(FCompiledUsesList); + FreeAndNil(FCompiledUsesListID); end; procedure TCompilerSuite.Run(AResult: TTestResult); @@ -810,9 +838,36 @@ begin TDebuggerSuite(Test[i]).RegisterDbgTest(ATestClass); end; -procedure TCompilerSuite.TestCompileUses(UsesDir: TUsesDir; out UsesLibDir); +procedure TCompilerSuite.TestCompileUses(UsesDir: TUsesDir; out UsesLibDir: String; out ExeID:string); +var + Opts: String; + i: Integer; + DirPostFix: String; begin + DirPostFix := SymbolTypeNames[UsesDir.SymbolType] + '_' + NameToFileName(CompilerInfo.Name); + UsesLibDir := AppendPathDelim(ExtractFilePath(UsesDir.DirName)) + 'lib__' + + DirPostFix; + if UsesDir.NamePostFix <> '' then + UsesLibDir := UsesLibDir + '__' + UsesDir.NamePostFix; + i := FCompiledUsesList.IndexOf(UsesLibDir); + if i < 0 then begin + if DirectoryExists(AppendPathDelim(UsesLibDir)) then + raise EAssertionFailedError.Create('Found existing dir before compiling: ' + UsesLibDir); + i := FCompiledUsesList.Add(UsesLibDir); + ExeID := '_U'+IntToStr(i)+UsesDir.ExeId+'_'+DirPostFix+'__'; + FCompiledUsesListID.Add(ExeID); + + CreateDirUTF8(UsesLibDir); + + Opts := SymbolTypeSwitches[UsesDir.SymbolType] + ' ' + UsesDir.ExtraOpts; + if not CompileHelper.TestCompileUnits(CompilerInfo.ExeName, Opts, UsesDir.DirName, UsesLibDir) + then + raise EAssertionFailedError.Create('Compilation Failed: ' + UsesDir.DirName + LineEnding + CompileHelper.LastError); + end + else begin + ExeID := FCompiledUsesListID[i]; + end; end; procedure TCompilerSuite.TestCompile(const PrgName: string; out ExeName: string; @@ -824,13 +879,23 @@ end; procedure TCompilerSuite.TestCompile(const PrgName: string; out ExeName: string; UsesDirs: array of TUsesDir; NamePostFix: String; ExtraArgs: String); var - ExePath, ErrMsg: String; + ExePath, ErrMsg, ExtraFUPath: String; + i: Integer; + NewLibDir, NewExeID: string; begin ExePath := ExtractFileNameWithoutExt(PrgName); ExeName := ExtractFileNameOnly(ExePath); ExePath := AppendPathDelim(copy(ExePath, 1, length(ExePath) - length(ExeName))); if DirectoryExistsUTF8(ExePath + 'lib') then ExePath := AppendPathDelim(ExePath + 'lib'); + + ExtraFUPath := ''; + for i := low(UsesDirs) to high(UsesDirs) do begin + TestCompileUses(UsesDirs[i], NewLibDir, NewExeID); + ExtraFUPath := ExtraFUPath + ' -Fu'+NewLibDir; + NamePostFix := NamePostFix + NewExeID; + end; + ExeName := ExePath + ExeName + FFileNameExt + NamePostFix + GetExeExt; if ExtraArgs <> '' then @@ -839,7 +904,10 @@ begin if FileExists(ExeName) then raise EAssertionFailedError.Create('Found existing file before compiling: ' + ExeName); FCompiledList.Add(ExeName); - ErrMsg := CompileHelper.TestCompile(PrgName, FSymbolSwitch + ' ' + FCompilerInfo.ExtraOpts + ExtraArgs, ExeName, CompilerInfo.ExeName); + ErrMsg := CompileHelper.TestCompile(PrgName, + FSymbolSwitch + ' ' + ExtraFUPath + ' ' + FCompilerInfo.ExtraOpts + ExtraArgs, + ExeName, + CompilerInfo.ExeName); if ErrMsg <> '' then begin debugln(ErrMsg); raise EAssertionFailedError.Create('Compilation Failed: ' + ExeName + LineEnding + ErrMsg); @@ -879,9 +947,9 @@ begin end; procedure TDebuggerSuite.TestCompile(const PrgName: string; out ExeName: string; - NamePostFix: String=''; ExtraArgs: String=''); + UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String=''); begin - Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs); + Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs); end; { TGDBTestsuite } @@ -915,9 +983,9 @@ begin end; procedure TGDBTestsuite.TestCompile(const PrgName: string; out ExeName: string; - NamePostFix: String=''; ExtraArgs: String=''); + UsesDirs: array of TUsesDir; NamePostFix: String=''; ExtraArgs: String=''); begin - Parent.TestCompile(PrgName, ExeName, NamePostFix, ExtraArgs); + Parent.TestCompile(PrgName, ExeName, UsesDirs, NamePostFix, ExtraArgs); end; { --- } diff --git a/debugger/test/Gdbmi/testwatches.pas b/debugger/test/Gdbmi/testwatches.pas index d74fc04d32..c73f22cf40 100644 --- a/debugger/test/Gdbmi/testwatches.pas +++ b/debugger/test/Gdbmi/testwatches.pas @@ -9,8 +9,8 @@ uses TestBase, Debugger, GDBMIDebugger, LCLProc, SynRegExpr, Forms, StdCtrls, Controls; const - BREAK_LINE_FOOFUNC = 160; - BREAK_LINE_FOOFUNC_NEST = 136; + BREAK_LINE_FOOFUNC = 230; + BREAK_LINE_FOOFUNC_NEST = 206; RUN_GDB_TEST_ONLY = -1; // -1 run all RUN_TEST_ONLY = -1; // -1 run all @@ -26,33 +26,7 @@ const *) type - { TTestWatches } - TTestWatches = class(TGDBTestCase) - private - FWatches: TcurrentWatches; - FDbgOutPut: String; - FDbgOutPutEnable: Boolean; - procedure DoDbgOutput(Sender: TObject; const AText: String); override; - public - procedure DebugInteract(dbg: TGDBMIDebugger); - - published - procedure TestWatches; - end; - -implementation - -var - DbgForm: TForm; - DbgMemo: TMemo; - DbgLog: Boolean; - -const - RNoPreQuote = '(^|[^''])'; // No open qoute (Either at start, or other char) - RNoPostQuote = '($|[^''])'; // No close qoute (Either at end, or other char) - -type TWatchExpectationFlag = (fnoDwrf, // no dwarf at all fnoDwrfNoSet, // no dwarf2 (-gw) without set @@ -62,23 +36,61 @@ type fTpMtch ); TWatchExpectationFlags = set of TWatchExpectationFlag; - TWatchExpectation = record - Exp: string; - Fmt: TWatchDisplayFormat; - Mtch: string; - Kind: TDBGSymbolKind; - TpNm: string; + TWatchExpectation = record + Expression: string; + DspFormat: TWatchDisplayFormat; + StackFrame: Integer; + ExpMatch: string; + ExpKind: TDBGSymbolKind; + ExpTypeName: string; Flgs: TWatchExpectationFlags; end; + TWatchExpectationArray = array of TWatchExpectation; -var - // direct commands to gdb, to check assumptions // only Exp and Mtch - ExpectGdbBrk1NoneNil: Array of TWatchExpectation; - // Watches - ExpectBrk1NoneNil: Array of TWatchExpectation; + + { TTestWatches } + + TTestWatches = class(TGDBTestCase) + private + FWatches: TcurrentWatches; + + ExpectBreakFooGdb: TWatchExpectationArray; // direct commands to gdb, to check assumptions // only Exp and Mtch + ExpectBreakSubFoo: TWatchExpectationArray; // Watches, evaluated in SubFoo (nested) + ExpectBreakFoo: TWatchExpectationArray; // Watches, evaluated in Foo + + FDbgOutPut: String; + FDbgOutPutEnable: Boolean; + + procedure DoDbgOutput(Sender: TObject; const AText: String); override; + procedure ClearAllTestArrays; + procedure AddTo(var ExpArray: TWatchExpectationArray; + AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; + AFlgs: TWatchExpectationFlags = []; + AStackFrame: Integer = 0 + ); + + procedure AddExpectBreakFooGdb; + procedure AddExpectBreakFooAll; + procedure AddExpectBreakFooMixInfo; + //procedure AddExpectBreakSubFoo; + procedure AddExpectBreakFooAndSubFoo; // check for caching issues + procedure RunTestWatches(NamePreFix: String; + TestExeName, ExtraOpts: String; + UsedUnits: array of TUsesDir + ); + public + procedure DebugInteract(dbg: TGDBMIDebugger); + published + procedure TestWatches; + end; + +implementation const + RNoPreQuote = '(^|[^''])'; // No open qoute (Either at start, or other char) + RNoPostQuote = '($|[^''])'; // No close qoute (Either at end, or other char) Match_Pointer = '\$[0-9A-F]+'; M_Int = 'Integer|LongInt'; @@ -89,20 +101,53 @@ const {%ebdregion * Classes * } // Todo: Dwarf fails with dereferenced var pointer types -procedure InitializeExpectGdbBrk1NoneNil; - procedure Add(AnExp: string; AFmt: TWatchDisplayFormat; - AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags - ); +function MatchPointer(TypeName: String=''): String; +begin + if TypeName = '' + then Result := '\$[0-9A-F]+' + else Result := TypeName+'\(\$[0-9A-F]+'; +end; + +function MatchRecord(TypeName: String; AContent: String = ''): String; +begin + Result := 'record '+TypeName+' .+'+AContent; +end; +function MatchRecord(TypeName: String; AValInt: integer; AValFoo: String = ''): String; +begin + Result := 'record '+TypeName+' .+ valint = '+IntToStr(AValInt); + If AValFoo <> '' then Result := Result + ',.* valfoo = '+AValFoo; +end; + +{ TTestWatches } + +procedure TTestWatches.ClearAllTestArrays; +begin + SetLength(ExpectBreakFooGdb, 0); + SetLength(ExpectBreakSubFoo, 0); + SetLength(ExpectBreakFoo, Length(ExpectBreakFoo)+1); +end; + +procedure TTestWatches.AddTo(var ExpArray: TWatchExpectationArray; AnExpr: string; + AFmt: TWatchDisplayFormat; AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; + AFlgs: TWatchExpectationFlags; AStackFrame: Integer = 0); +begin + SetLength(ExpArray, Length(ExpArray)+1); + with ExpArray[Length(ExpArray)-1] do begin + Expression := AnExpr; + DspFormat := AFmt; + ExpMatch := AMtch; + ExpKind := AKind; + ExpTypeName := ATpNm; + Flgs := AFlgs; + StackFrame := AStackFrame; + end; +end; + +procedure TTestWatches.AddExpectBreakFooGdb; + procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags); begin - SetLength(ExpectGdbBrk1NoneNil, Length(ExpectGdbBrk1NoneNil)+1); - with ExpectGdbBrk1NoneNil[Length(ExpectGdbBrk1NoneNil)-1] do begin - Exp := AnExp; - Fmt := AFmt; - Mtch := AMtch; - Kind := AKind; - TpNm := ATpNm; - Flgs := AFlgs; - end; + AddTo(ExpectBreakFooGdb,AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs ) end; begin Add('ptype ArgTFoo', wdfDefault, 'type = \^TFoo = class : PUBLIC TObject', skClass, '', []); @@ -110,39 +155,18 @@ begin Add('-data-evaluate-expression sizeof(ArgTFoo)', wdfDefault, 'value="(4|8)"|(parse|syntax) error in expression', skClass, '', []); Add('-data-evaluate-expression sizeof(ArgTFoo^)', wdfDefault, 'value="\d\d+"|(parse|syntax) error in expression', skClass, '', []); + + if RUN_GDB_TEST_ONLY > 0 then begin + ExpectBreakFooGdb[0] := ExpectBreakFooGdb[abs(RUN_GDB_TEST_ONLY)]; + SetLength(ExpectBreakFooGdb, 1); + end; end; -procedure InitializeExpectBrk1NoneNil; - procedure Add(AnExp: string; AFmt: TWatchDisplayFormat; - AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; - AFlgs: TWatchExpectationFlags = [] - ); +procedure TTestWatches.AddExpectBreakFooAll; + procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags); begin - SetLength(ExpectBrk1NoneNil, Length(ExpectBrk1NoneNil)+1); - with ExpectBrk1NoneNil[Length(ExpectBrk1NoneNil)-1] do begin - Exp := AnExp; - Fmt := AFmt; - Mtch := AMtch; - Kind := AKind; - TpNm := ATpNm; - Flgs := AFlgs; - end; - end; - - function MatchPointer(TypeName: String=''): String; - begin - if TypeName = '' - then Result := '\$[0-9A-F]+' - else Result := TypeName+'\(\$[0-9A-F]+'; - end; - function MatchRecord(TypeName: String; AContent: String = ''): String; - begin - Result := 'record '+TypeName+' .+'+AContent; - end; - function MatchRecord(TypeName: String; AValInt: integer; AValFoo: String = ''): String; - begin - Result := 'record '+TypeName+' .+ valint = '+IntToStr(AValInt); - If AValFoo <> '' then Result := Result + ',.* valfoo = '+AValFoo; + AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs ) end; begin {%region * records * } @@ -294,6 +318,7 @@ begin //Add('ArgTFoo=nil', wdfDefault, 'False', skSimple, 'bool', []); //Add('not(ArgTFoo=nil)', wdfDefault, 'True', skSimple, 'bool', []); //Add('ArgTFoo<>nil', wdfDefault, 'True', skSimple, 'bool', []); + {%endregion * Classes * } {%region * Strings * } @@ -510,17 +535,55 @@ begin *) {%endregion * procedure/function/method * } + if RUN_TEST_ONLY > 0 then begin + ExpectBreakFoo[0] := ExpectBreakFoo[abs(RUN_TEST_ONLY)]; + SetLength(ExpectBreakFoo, 1); + end; end; -{ TTestWatches } +procedure TTestWatches.AddExpectBreakFooMixInfo; + procedure Add(AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags); + begin + AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs ) + end; +begin + // MIXED symbol info types + Add('VarFooOther', wdfDefault, '', skClass, 'TObject', []); + Add('TFooTestTestBase(VarFooOther)', wdfDefault, '', skClass, 'TFooTestTestBase', []); + Add('VarStatIntArray', wdfDefault, '10,[\s\r\n]+12,[\s\r\n]+14,[\s\r\n]+16,[\s\r\n]+18', + skSimple, 'TStatIntArray', + []); +end; + +procedure TTestWatches.AddExpectBreakFooAndSubFoo; + procedure AddF(AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags; + AStackFrame: Integer=0); + begin + AddTo(ExpectBreakFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs, AStackFrame) + end; + procedure AddS(AnExpr: string; AFmt: TWatchDisplayFormat; + AMtch: string; AKind: TDBGSymbolKind; ATpNm: string; AFlgs: TWatchExpectationFlags; + AStackFrame: Integer=0); + begin + AddTo(ExpectBreakSubFoo, AnExpr, AFmt, AMtch, AKind, ATpNm, AFlgs, AStackFrame) + end; +begin + AddS('VarCacheTest1', wdfDefault, MatchRecord('TCacheTest', 'CTVal = 101'), + skRecord, 'TCacheTest', []); + AddF('VarCacheTest1', wdfDefault, ' = \{.*(<|vptr\$)TObject>?.+CTVal = 201', + skClass, 'TCacheTest(Type)?', [fTpMtch]); + + AddS('VarCacheTest2', wdfDefault, '102', skSimple, M_Int, [fTpMtch], 0); + AddS('VarCacheTest2', wdfDefault, '202', skSimple, M_Int, [fTpMtch], 1); +end; procedure TTestWatches.DoDbgOutput(Sender: TObject; const AText: String); begin inherited DoDbgOutput(Sender, AText); if FDbgOutPutEnable then FDbgOutPut := FDbgOutPut + AText; - if DbgLog and (DbgMemo <> nil) then - DbgMemo.Lines.Add(AText); end; procedure TTestWatches.DebugInteract(dbg: TGDBMIDebugger); @@ -533,7 +596,9 @@ begin end; end; -procedure TTestWatches.TestWatches; +procedure TTestWatches.RunTestWatches(NamePreFix: String; TestExeName, ExtraOpts: String; + UsedUnits: array of TUsesDir); + function SkipTest(const Data: TWatchExpectation): Boolean; begin @@ -556,13 +621,15 @@ procedure TTestWatches.TestWatches; s: String; flag: Boolean; WV: TWatchValue; + Stack: Integer; begin rx := nil; + Stack := Data.StackFrame; - Name := Name + ' ' + Data.Exp + ' (' + TWatchDisplayFormatNames[Data.Fmt] + ')'; + Name := Name + ' ' + Data.Expression + ' (' + TWatchDisplayFormatNames[Data.DspFormat] + ')'; flag := AWatch <> nil; if flag then begin; - WV := AWatch.Values[1, 0];// trigger read + WV := AWatch.Values[1, Stack];// trigger read s := WV.Value; flag := flag and TestTrue (Name+ ' (HasValue)', WV.Validity = ddsValid); //flag := flag and TestFalse (Name+ ' (One Value)', AWatch.HasMultiValue); @@ -573,14 +640,14 @@ procedure TTestWatches.TestWatches; if flag then begin rx := TRegExpr.Create; rx.ModifierI := true; - rx.Expression := Data.Mtch; - if Data.Mtch <> '' - then TestTrue(Name + ' Matches "'+Data.Mtch + '", but was "' + s + '"', rx.Exec(s)); + rx.Expression := Data.ExpMatch; + if Data.ExpMatch <> '' + then TestTrue(Name + ' Matches "'+Data.ExpMatch + '", but was "' + s + '"', rx.Exec(s)); end; - flag := (AWatch <> nil) and (Data.TpNm <> ''); + flag := (AWatch <> nil) and (Data.ExpTypeName <> ''); if flag then flag := TestTrue(Name + ' has typeinfo', WV.TypeInfo <> nil); - if flag then flag := TestEquals(Name + ' kind', KindName[Data.Kind], KindName[WV.TypeInfo.Kind]); + if flag then flag := TestEquals(Name + ' kind', KindName[Data.ExpKind], KindName[WV.TypeInfo.Kind]); if flag then begin if fTpMtch in Data.Flgs then begin @@ -588,138 +655,190 @@ procedure TTestWatches.TestWatches; s := WV.TypeInfo.TypeName; rx := TRegExpr.Create; rx.ModifierI := true; - rx.Expression := Data.TpNm; - TestTrue(Name + ' TypeName matches '+Data.TpNm+' but was '+WV.TypeInfo.TypeName, rx.Exec(s)) - end - else TestEquals(Name + ' TypeName', LowerCase(Data.TpNm), LowerCase(WV.TypeInfo.TypeName)); + rx.Expression := Data.ExpTypeName; + TestTrue(Name + ' TypeName matches '+Data.ExpTypeName+' but was '+WV.TypeInfo.TypeName, rx.Exec(s)) + end + else TestEquals(Name + ' TypeName', LowerCase(Data.ExpTypeName), LowerCase(WV.TypeInfo.TypeName)); end; FreeAndNil(rx); end; var - TestExeName: string; dbg: TGDBMIDebugger; i: Integer; - WList: Array of TCurrentWatch; -begin - if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestWatch')] then exit; + WList, WListSub: Array of TCurrentWatch; + +begin + TestBaseName := NamePreFix; - ClearTestErrors; try - TestCompile(AppDir + 'WatchesPrg.pas', TestExeName); + TestCompile(AppDir + 'WatchesPrg.pas', TestExeName, UsedUnits, '', ExtraOpts); except - on e: Exception do Fail('Compile error: ' + e.Message); + on e: Exception do begin + TestTrue('Compile error: ' + e.Message, False); + exit; + end; end; try dbg := StartGDB(AppDir, TestExeName); FWatches := Watches.CurrentWatches; - if (RUN_TEST_ONLY >= 0) or (RUN_GDB_TEST_ONLY >= 0) then begin - DbgLog := False; - if DbgForm = nil then begin - DbgForm := TForm.Create(Application); - DbgMemo := TMemo.Create(DbgForm); - DbgMemo.Parent := DbgForm; - DbgMemo.Align := alClient; - DbgForm.Show; - end; - DbgMemo.Lines.Add(''); - DbgMemo.Lines.Add(' *** ' + Parent.TestSuiteName + ' ' + Parent.TestName + ' ' + TestSuiteName+' '+TestName); - DbgMemo.Lines.Add(''); - end; - - (* Add breakpoints *) - //with dbg.BreakPoints.Add('WatchesPrg.pas', 44) do begin - // InitialEnabled := True; - // Enabled := True; - //end; with dbg.BreakPoints.Add('WatchesPrg.pas', BREAK_LINE_FOOFUNC) do begin InitialEnabled := True; Enabled := True; end; + with dbg.BreakPoints.Add('WatchesPrg.pas', BREAK_LINE_FOOFUNC_NEST) do begin + InitialEnabled := True; + Enabled := True; + end; - (* Create all watches *) - SetLength(WList, high(ExpectBrk1NoneNil)+1); - if RUN_TEST_ONLY >= 0 then begin - i := RUN_TEST_ONLY; - WList[i] := TCurrentWatch.Create(FWatches); - WList[i].Expression := ExpectBrk1NoneNil[i].Exp; - WList[i].DisplayFormat := ExpectBrk1NoneNil[i].Fmt; - WList[i].enabled := True; - end - else - for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do begin - if not SkipTest(ExpectBrk1NoneNil[i]) then begin - WList[i] := TCurrentWatch.Create(FWatches); - WList[i].Expression := ExpectBrk1NoneNil[i].Exp; - WList[i].DisplayFormat := ExpectBrk1NoneNil[i].Fmt; - WList[i].enabled := True; - end; - end; - - - (* Start debugging *) if dbg.State = dsError then Fail(' Failed Init'); - dbg.ShowConsole := True; + (* Create all watches *) + SetLength(WList, length(ExpectBreakFoo)); + for i := low(ExpectBreakFoo) to high(ExpectBreakFoo) do begin + if not SkipTest(ExpectBreakFoo[i]) then begin + WList[i] := TCurrentWatch.Create(FWatches); + WList[i].Expression := ExpectBreakFoo[i].Expression; + WList[i].DisplayFormat := ExpectBreakFoo[i].DspFormat; + WList[i].enabled := True; + end; + end; + SetLength(WListSub, length(ExpectBreakSubFoo)); + for i := low(ExpectBreakSubFoo) to high(ExpectBreakSubFoo) do begin + if not SkipTest(ExpectBreakSubFoo[i]) then begin + WListSub[i] := TCurrentWatch.Create(FWatches); + WListSub[i].Expression := ExpectBreakSubFoo[i].Expression; + WListSub[i].DisplayFormat := ExpectBreakSubFoo[i].DspFormat; + WListSub[i].enabled := True; + end; + end; + (* Start debugging *) + dbg.ShowConsole := True; dbg.Run; (* Hit first breakpoint: Test *) + (* SubFoo -- Called with none nil data *) FDbgOutPutEnable := True; - if (RUN_TEST_ONLY < 0) or (RUN_GDB_TEST_ONLY >= 0) then begin - if RUN_GDB_TEST_ONLY >= 0 then begin - i := RUN_GDB_TEST_ONLY; + for i := low(ExpectBreakFooGdb) to high(ExpectBreakFooGdb) do begin + if not SkipTest(ExpectBreakFooGdb[i]) then begin FDbgOutPut := ''; - dbg.TestCmd(ExpectGdbBrk1NoneNil[i].Exp); - TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectGdbBrk1NoneNil[i], FDbgOutPut); - end - else - for i := low(ExpectGdbBrk1NoneNil) to high(ExpectGdbBrk1NoneNil) do begin - if not SkipTest(ExpectGdbBrk1NoneNil[i]) then begin - FDbgOutPut := ''; - dbg.TestCmd(ExpectGdbBrk1NoneNil[i].Exp); - TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectGdbBrk1NoneNil[i], FDbgOutPut); - end; - end; + dbg.TestCmd(ExpectBreakFooGdb[i].Expression); + TestWatch('Brk1 Direct Gdb '+IntToStr(i)+' ', nil, ExpectBreakFooGdb[i], FDbgOutPut); + end; end; FDbgOutPutEnable := False; - if (RUN_GDB_TEST_ONLY < 0) or (RUN_TEST_ONLY >= 0) then begin - if RUN_TEST_ONLY >= 0 then begin - i := RUN_TEST_ONLY; - TestWatch('Brk1 ', WList[i], ExpectBrk1NoneNil[i]); - end - else - for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do begin - if not SkipTest(ExpectBrk1NoneNil[i]) then - TestWatch('Brk1 '+IntToStr(i)+' ', WList[i], ExpectBrk1NoneNil[i]); - end; + for i := low(ExpectBreakSubFoo) to high(ExpectBreakSubFoo) do begin + if not SkipTest(ExpectBreakSubFoo[i]) then + TestWatch('Brk1 '+IntToStr(i)+' ', WListSub[i], ExpectBreakSubFoo[i]); end; dbg.Run; + (* Hit second breakpoint: Test *) + (* Foo -- Called with none nil data *) + + for i := low(ExpectBreakFoo) to high(ExpectBreakFoo) do begin + if not SkipTest(ExpectBreakFoo[i]) then + TestWatch('Brk1 '+IntToStr(i)+' ', WList[i], ExpectBreakFoo[i]); + end; + + // TODO: 2nd round, with NIL data //DebugInteract(dbg); dbg.Stop; - finally - dbg.Free; - CleanGdb; - - if (DbgMemo <> nil) and (TestErrors <> '') then DbgMemo.Lines.Add(TestErrors); - //debugln(FailText) - AssertTestErrors; + except + on e: Exception do begin + TestTrue('Error: ' + e.Message, False); + exit; + end; end; + dbg.Free; + CleanGdb; +end; + +procedure TTestWatches.TestWatches; +var + TestExeName: string; + UsedUnits: TUsesDir; +begin + if not TestControlForm.CheckListBox1.Checked[TestControlForm.CheckListBox1.Items.IndexOf('TTestWatch')] then exit; + + ClearTestErrors; + + ClearAllTestArrays; + AddExpectBreakFooGdb; + AddExpectBreakFooAll; + //AddExpectBreakFooMixInfo; + AddExpectBreakFooAndSubFoo; + RunTestWatches('', TestExeName, '', []); + + + ClearAllTestArrays; + AddExpectBreakFooMixInfo; + with UsedUnits do begin + DirName:= AppDir + 'u1\unitw1.pas'; + ExeId:= ''; + SymbolType:= stNone; + ExtraOpts:= ''; + NamePostFix:= '' + end; + RunTestWatches('unitw1=none', TestExeName, '-dUSE_W1', [UsedUnits]); + + if (stStabs in CompilerInfo.SymbolTypes) and (stStabs in DebuggerInfo.SymbolTypes) + then begin + ClearAllTestArrays; + AddExpectBreakFooMixInfo; + with UsedUnits do begin + DirName:= AppDir + 'u1\unitw1.pas'; + ExeId:= ''; + SymbolType:= stStabs; + ExtraOpts:= ''; + NamePostFix:= '' + end; + RunTestWatches('unitw1=stabs', TestExeName, '-dUSE_W1', [UsedUnits]); + end; + + if (stDwarf in CompilerInfo.SymbolTypes) and (stDwarf in DebuggerInfo.SymbolTypes) + then begin + ClearAllTestArrays; + AddExpectBreakFooMixInfo; + with UsedUnits do begin + DirName:= AppDir + 'u1\unitw1.pas'; + ExeId:= ''; + SymbolType:= stDwarf; + ExtraOpts:= ''; + NamePostFix:= '' + end; + RunTestWatches('unitw1=dwarf', TestExeName, '-dUSE_W1', [UsedUnits]); + end; + + if (stDwarf3 in CompilerInfo.SymbolTypes) and (stDwarf3 in DebuggerInfo.SymbolTypes) + then begin + ClearAllTestArrays; + AddExpectBreakFooMixInfo; + with UsedUnits do begin + DirName:= AppDir + 'u1\unitw1.pas'; + ExeId:= ''; + SymbolType:= stDwarf3; + ExtraOpts:= ''; + NamePostFix:= '' + end; + RunTestWatches('unitw1=dwarf_3', TestExeName, '-dUSE_W1', [UsedUnits]); + end; + + + AssertTestErrors; end; initialization - InitializeExpectBrk1NoneNil; - InitializeExpectGdbBrk1NoneNil; RegisterDbgTest(TTestWatches); end.