From e4121d2b0b296ffad5014e6702dda28fa39f8100 Mon Sep 17 00:00:00 2001 From: martin Date: Thu, 16 Dec 2010 01:43:28 +0000 Subject: [PATCH] DBG: improved display of watches git-svn-id: trunk@28725 - --- debugger/debugger.pp | 7 +- debugger/gdbmidebugger.pp | 137 +-- debugger/gdbtypeinfo.pp | 155 +++- debugger/inspectdlg.pas | 2 +- debugger/test/Gdbmi/TestApps/WatchesPrg.pas | 890 +++++++++++++++++++- debugger/test/Gdbmi/testbase.pas | 115 +-- debugger/test/Gdbmi/testwatches.pas | 337 ++++++-- 7 files changed, 1402 insertions(+), 241 deletions(-) diff --git a/debugger/debugger.pp b/debugger/debugger.pp index df67d386c4..4ea2dad36c 100644 --- a/debugger/debugger.pp +++ b/debugger/debugger.pp @@ -460,6 +460,10 @@ type type TDBGSymbolKind = (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer, skVariant); + TDBGSymbolAttribute = (saRefParam, // var, const, constref passed by reference + saInternalPointer // PointerToObject + ); + TDBGSymbolAttributes = set of TDBGSymbolAttribute; TDBGFieldLocation = (flPrivate, flProtected, flPublic, flPublished); TDBGFieldFlag = (ffVirtual,ffConstructor,ffDestructor); TDBGFieldFlags = set of TDBGFieldFlag; @@ -528,12 +532,12 @@ type { TDBGType } TDBGType = class(TObject) - private protected FAncestor: String; FResult: TDBGType; FResultString: String; FArguments: TDBGTypes; + FAttributes: TDBGSymbolAttributes; FFields: TDBGFields; FKind: TDBGSymbolKind; FMembers: TStrings; @@ -548,6 +552,7 @@ type property Arguments: TDBGTypes read FArguments; property Fields: TDBGFields read FFields; property Kind: TDBGSymbolKind read FKind; + property Attributes: TDBGSymbolAttributes read FAttributes; property TypeName: String read FTypeName; property Members: TStrings read FMembers; property Result: TDBGType read FResult; diff --git a/debugger/gdbmidebugger.pp b/debugger/gdbmidebugger.pp index cc0bc3969c..2df3fb8d9f 100644 --- a/debugger/gdbmidebugger.pp +++ b/debugger/gdbmidebugger.pp @@ -1189,12 +1189,11 @@ type { TGDBMIType } TGDBMIType = class(TGDBType) - private - FIsAmpersandAddr: Boolean; - protected public - constructor CreateFromResult(const AResult: TGDBMIExecResult); - property IsAmpersandAddr: Boolean read FIsAmpersandAddr; // for dwarf only "&TypeName" indicates a param by ref (var, const, constref) + constructor CreateFromResult(const AResult: TGDBMIExecResult; + const AWhatIsValue: String = ''; + const AWhatIsType: String = ''; + AClassIsPointer: Boolean = False); end; { TGDBStringIterator } @@ -7707,29 +7706,11 @@ end; { TGDBMIType } -constructor TGDBMIType.CreateFromResult(const AResult: TGDBMIExecResult); -var - s: String; - i: Integer; +constructor TGDBMIType.CreateFromResult(const AResult: TGDBMIExecResult; + const AWhatIsValue: String = ''; const AWhatIsType: String = ''; AClassIsPointer: Boolean = False); begin // TODO: add check ? - - // tfClassIsPointer can be ignored, because the "&" only occurs with dwarf, which always has tfClassIsPointer - FIsAmpersandAddr := False; - s := AResult.Values; - i := pos('type = &', s); - if i > 0 then begin - FIsAmpersandAddr := True; - if (copy(s, i+8, 15) = '__vtbl_ptr_type') or - //( (tfClassIsPointer in TargetInfo^.TargetFlags) and - (copy(s, i+8, 5) = 'class') //) - then - s[i+7] := '^' - else - Delete(s, i + 7, 1); - end; - - CreateFromValues(s); + CreateFromValues(AResult.Values, AWhatIsValue, AWhatIsType, AClassIsPointer); end; { TGDBStringIterator } @@ -8322,15 +8303,57 @@ end; function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String): TGDBType; var - R: TGDBMIExecResult; + WIExprRes, PTypeRes, WITypeRes: TGDBMIExecResult; + WIExprVal, WIExprValCln, WITypeValS2: String; begin - if not ExecuteCommand('ptype %s', [AExpression], R) - or (R.State = dsError) + Result := nil; + WIExprValCln := ''; + if ExecuteCommand('whatis %s', [AExpression], WIExprRes) + and (WIExprRes.State <> dsError) + then begin + WIExprVal := ParseTypeFromGdb(WIExprRes.Values); + WIExprValCln := WIExprVal; + while (WIExprValCln<>'') and (WIExprValCln[1] in ['^', '&']) do delete(WIExprValCln, 1, 1); + + if (pos(' ', WIExprValCln) > 0) or (WIExprValCln = '') then begin + if ExecuteCommand('ptype %s', [AExpression], PTypeRes) // can not ptype with spaces + and (PTypeRes.State <> dsError) + then begin + Result := TGdbMIType.CreateFromResult(PTypeRes, WIExprRes.Values, '', tfClassIsPointer in TargetInfo^.TargetFlags); + exit; + end; + end + else begin + if ExecuteCommand('ptype %s', [WIExprValCln], PTypeRes) + and (PTypeRes.State <> dsError) + then begin + + WITypeValS2 := ''; + if (Pos(' = class ', PTypeRes.Values) > 0) + and (tfClassIsPointer in TargetInfo^.TargetFlags) // ptype will give ^ for pointer-to-class or just class + and (pos('type = ^^', PTypeRes.Values) <= 0) // not known to be a pointer (not sure it ever happens) + and (WIExprVal[1] <> '^') // not known to be a pointer (not sure it ever happens) + and ExecuteCommand('whatis %s', [WIExprValCln], WITypeRes) + and (PTypeRes.State <> dsError) + then WITypeValS2 := WITypeRes.Values; + + Result := TGdbMIType.CreateFromResult(PTypeRes, WIExprRes.Values, WITypeValS2, tfClassIsPointer in TargetInfo^.TargetFlags); + exit; + end; + end; + end; + + if (PTypeRes.State = dsError) and (pos('msg="No symbol ', PTypeRes.Values) > 0) + then exit; + + // try ptype on the value + if not ExecuteCommand('ptype %s', [AExpression], PTypeRes) + or (PTypeRes.State = dsError) then begin Result := nil; end else begin - Result := TGdbMIType.CreateFromResult(R); + Result := TGdbMIType.CreateFromResult(PTypeRes, '', '', tfClassIsPointer in TargetInfo^.TargetFlags); end; end; @@ -9209,15 +9232,14 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean; if ResultInfo = nil then ResultInfo := GetGDBTypeInfo(AnExpression); if (ResultInfo = nil) then Exit; + FTypeInfo := ResultInfo; case ResultInfo.Kind of skPointer: begin AnExpression := GetPart([], [' '], FTextValue, False, False); Val(AnExpression, addr, e); - if e <> 0 then begin - FreeAndNil(ResultInfo); + if e <> 0 then Exit; - end; AnExpression := Lowercase(ResultInfo.TypeName); case StringCase(AnExpression, ['char', 'character', 'ansistring', '__vtbl_ptr_type', @@ -9262,7 +9284,7 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean; AnExpression[1] := 'T'; if Length(AnExpression) > 1 then AnExpression[2] := UpperCase(AnExpression[2])[1]; end; - FTextValue := PascalizePointer(FTextValue, '^' + AnExpression); + FTextValue := PascalizePointer(FTextValue, AnExpression); end; end; @@ -9276,14 +9298,19 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean; skClass: begin Val(FTextValue, addr, e); //Get the class mem address - if e = 0 then begin //No error ? - if Addr = 0 - then FTextValue := 'nil' - else begin - AnExpression := GetInstanceClassName(Addr); - if AnExpression = '' then AnExpression := '???'; //No instanced class found - FTextValue := 'class ' + AnExpression + ' ' + FTextValue; - end; + if (e = 0) and (addr = 0) + then FTextValue := 'nil'; + + if (FTextValue <> '') and (FTypeInfo <> nil) + then begin + FTextValue := '<' + FTypeInfo.TypeName + '> = ' + FTextValue; + end + else + if (e = 0) and (addr <> 0) + then begin //No error ? + AnExpression := GetInstanceClassName(Addr); + if AnExpression = '' then AnExpression := '???'; //No instanced class found + FTextValue := 'instance of ' + AnExpression + ' ' + FTextValue; end; end; @@ -9305,7 +9332,6 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean; end; end; - FTypeInfo := ResultInfo; PutValuesInTree; FTextValue := FormatResult(FTextValue); end; @@ -9488,17 +9514,30 @@ function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean; Result := False; FTypeInfo := GetGDBTypeInfo(AnExpression); if FTypeInfo = nil - then exit; - - if TGdbMIType(FTypeInfo).IsAmpersandAddr and (FTypeInfo.TypeName <> '') then begin - Result := ExecuteCommand('-data-evaluate-expression %s(%s)', [FTypeInfo.TypeName, AnExpression], R); + ResultList := TGDBMINameValueList.Create(LastExecResult.Values); + FTextValue := ResultList.Values['msg']; + FreeAndNil(ResultList); + exit; + end; + + if (saInternalPointer in FTypeInfo.Attributes) + then begin + Result := ExecuteCommand('-data-evaluate-expression %s%s', [AnExpression, '^'], R); Result := Result and (R.State <> dsError); end; - if not Result then - Result := ExecuteCommand('-data-evaluate-expression %s', [AnExpression], R); + if (not Result) + and (saRefParam in FTypeInfo.Attributes) and (FTypeInfo.InternalTypeName <> '') + then begin + Result := ExecuteCommand('-data-evaluate-expression %s(%s)', [FTypeInfo.InternalTypeName, AnExpression], R); + Result := Result and (R.State <> dsError); + end; + + if (not Result) + then Result := ExecuteCommand('-data-evaluate-expression %s', [AnExpression], R); Result := Result and (R.State <> dsError); + if (not Result) and (not StoreError) then exit; diff --git a/debugger/gdbtypeinfo.pp b/debugger/gdbtypeinfo.pp index e587464299..1bb1d95526 100644 --- a/debugger/gdbtypeinfo.pp +++ b/debugger/gdbtypeinfo.pp @@ -61,12 +61,20 @@ type { TGDBType } TGDBType = class(TDBGType) + private + FInternalTypeName: string; public - constructor CreateFromValues(const AValues: String); + constructor CreateFromValues(const AValues: String; + AWhatIsValue: String = ''; + const AWhatIsType: String = ''; + AClassIsPointer: Boolean = False); + // InternalTypeName: include ^ for TObject, if needed + property InternalTypeName: string read FInternalTypeName; end; function CreatePTypeValueList(AResultValues: String): TStringList; +function ParseTypeFromGdb(const ATypeText: string): string; implementation @@ -248,9 +256,38 @@ begin end; end; +function ParseTypeFromGdb(const ATypeText: string): string; +var + StartIdx, EndIdx, BracketCnt, ln: Integer; + EndPtr: PChar; +begin + Result := ''; + StartIdx := pos('type = ', ATypeText); + if StartIdx <= 0 then exit; + inc(StartIdx, 7); + EndIdx := StartIdx; + EndPtr := @ATypeText[EndIdx]; + ln := length(ATypeText); + BracketCnt := 0; + while (EndIdx <= ln) do begin + case EndPtr^ of + ' ' : if BracketCnt = 0 then break; + '[', '{' : inc(BracketCnt); + ']', '}' : dec(BracketCnt); + '\' : if (EndIdx < ln) and ((EndPtr+1)^ = 'n') then break; + #0..#31: break; + end; + inc(EndPtr); + inc(EndIdx); + end; + Result := copy(ATypeText, StartIdx, EndIdx-StartIdx); +end; + { TGDBPType } -constructor TGDBType.CreateFromValues(const AValues: String); +constructor TGDBType.CreateFromValues(const AValues: String; + AWhatIsValue: String = ''; const AWhatIsType: String = ''; + AClassIsPointer: Boolean = False); var S, Line: String; Lines: TStringList; @@ -440,44 +477,104 @@ var end; var - HasClass: Boolean; + ParsedWhatIsValue, ParsedWhatIsType: string; begin - Create(skSimple, ''); - - if AValues = '' then Exit; + ParsedWhatIsValue := ParseTypeFromGdb(AWhatIsValue); + ParsedWhatIsType := ParseTypeFromGdb(AWhatIsType); Lines := TStringList.Create; try Lines.Text := AValues; - if Lines.Count = 0 then Exit; - Line := Lines[0]; - Lines.Delete(0); + if Lines.Count > 0 then begin + Line := Lines[0]; + Lines.Delete(0); + end + else Line := ''; + S := ParseTypeFromGdb(Line); - S := GetPart(['type = '], [' '], Line); - if S = '' then Exit; - HasClass := Pos(' = class ', Line) > 0; - if HasClass - and (S[2] <> '^') // pointer to class is handled next - then begin - FKind:=skClass; - if S[1] = '^' then begin - FKind:=skPointer; - FTypeName := GetPart(['^'], [' '], S); - end else begin - FTypeName := GetPart([], ['{'], S); - DoClass; + FAttributes := []; + if (ParsedWhatIsValue <> '') and (ParsedWhatIsValue[1] = '&') then begin + Delete(ParsedWhatIsValue, 1, 1); + include(FAttributes, saRefParam); + end; + + Create(skSimple, ParsedWhatIsValue); + FInternalTypeName := ParsedWhatIsValue; + + if Pos(' = class ', Line) > 0 then begin + // Class or pointer to class + if AClassIsPointer and (S[1] = '^') then begin + // class: dwarf type, always pefixed with ^ + + if (length(s) >= 2) and (s[2] = '^') + then begin + FKind:=skPointer; + if FTypeName = '' + then FTypeName := copy(s, 3, length(s)); + end + else if (ParsedWhatIsValue <> '') and (ParsedWhatIsValue[1] = '^') + and (pos(' = class', AWhatIsValue) <= 0) + then begin + FKind:=skPointer; // pointer to another named type + if FTypeName = '' + then FTypeName := copy(ParsedWhatIsValue, 2, length(ParsedWhatIsValue)); + end + else if (ParsedWhatIsType <> '') and (ParsedWhatIsType[1] = '^') + and (pos(' = class', AWhatIsType) <= 0) + then begin + FKind:=skPointer; // pointer to another named type + if FTypeName = '' + then FTypeName := copy(ParsedWhatIsType, 2, length(ParsedWhatIsType)); + end + else begin + include(FAttributes, saInternalPointer); + if FTypeName = '' + then FTypeName := GetPart([], ['{'], S); + DoClass; + end; + + if FInternalTypeName = '' + then FInternalTypeName := FTypeName; + + if (FInternalTypeName <> '') and (FInternalTypeName[1] <> '^') + and (saInternalPointer in FAttributes) + then FInternalTypeName := '^' + FInternalTypeName; + + end + else begin + // class: stabs type, not normaly prefixed + + if (length(s) >= 1) and (s[1] = '^') + then begin + FKind:=skPointer; + if FTypeName = '' + then FTypeName := copy(s, 2, length(s)); + end + else begin + include(FAttributes, saInternalPointer); + if FTypeName = '' + then FTypeName := GetPart([], ['{'], S); + DoClass; + end; + + if FInternalTypeName = '' + then FInternalTypeName := FTypeName; end; end - else if S[1] = '^' + + else + if (S[1] = '^') + or ((ParsedWhatIsValue <> '') and (ParsedWhatIsValue[1] = '^')) + or ((ParsedWhatIsType <> '') and (ParsedWhatIsType[1] = '^')) then begin FKind := skPointer; - if HasClass - then FTypeName := GetPart(['^^'], [' ='], S) - else FTypeName := GetPart(['^'], [' ='], S); + if FTypeName = '' + then FTypeName := GetPart(['^'], [' ='], S); // strip brackets FTypeName := GetPart(['(', ''], [')'], FTypeName); end + else if S = 'set' then DoSet else if S = 'procedure' @@ -488,7 +585,8 @@ begin then DoEnum else if Pos(' = record', Line) > 0 then begin - FTypeName := S; + if FTypeName = '' + then FTypeName := S; DoRecord end else if S = 'record' @@ -498,7 +596,8 @@ begin end else begin FKind := skSimple; - FTypeName := S; + if FTypeName = '' + then FTypeName := S; end; finally diff --git a/debugger/inspectdlg.pas b/debugger/inspectdlg.pas index 35eb0d5ab9..2fa257a99f 100644 --- a/debugger/inspectdlg.pas +++ b/debugger/inspectdlg.pas @@ -176,7 +176,7 @@ begin PropertiesPage.TabVisible:=false; MethodsPage.TabVisible:=false; if not Assigned(FDBGInfo) then exit; - EditInspected.Text:=FExpression+' : ^'+FDBGInfo.TypeName + ' = ' + FDBGInfo.Value.AsString; + EditInspected.Text:=FExpression+' : '+FDBGInfo.TypeName + ' = ' + FDBGInfo.Value.AsString; GridDataSetup; FGridData.Cells[0,1]:=FExpression; FGridData.Cells[1,1]:='Pointer to '+FDBGInfo.TypeName; diff --git a/debugger/test/Gdbmi/TestApps/WatchesPrg.pas b/debugger/test/Gdbmi/TestApps/WatchesPrg.pas index fa167d9102..f98d9aa89c 100644 --- a/debugger/test/Gdbmi/TestApps/WatchesPrg.pas +++ b/debugger/test/Gdbmi/TestApps/WatchesPrg.pas @@ -3,38 +3,884 @@ program WatchesPrg; uses sysutils; -procedure Foo( - ArgAnsiString1: AnsiString; var ArgAnsiString2: AnsiString; const ArgAnsiString3: AnsiString; - ArgChar1: Char; var ArgChar2: Char; const ArgChar3: Char +type + TFoo = class; + + { records } + TRec = record + ValInt: Integer; + ValFoo: TFoo; + end; + + PRec = ^TRec; + PPRec = ^PRec; + + TNewRec = type TRec; + + { Classes } + + TFoo = class + public + ValueInt: Integer; + ValueFoo: TFoo; + ValueRec: TRec; + property PropInt: Integer read ValueInt write ValueInt; + 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; + + { ClassesTyps } + TFooClass = Class of TFoo; + PFooClass = ^TFooClass; + PPFooClass = ^PFooClass; + + TNewFooClass = class of TNewFoo; + PNewFooClass = ^TNewFooClass; + + { strings } + TMyAnsiString = AnsiString; + PMyAnsiString = ^TMyAnsiString; + PPMyAnsiString = ^PMyAnsiString; + + TNewAnsiString = type AnsiString; + PNewAnsiString = ^TNewAnsiString; + + + TMyShortString = ShortString; + PMyShortString = ^TMyShortString; + PPMyShortString = ^PMyShortString; + + TNewhortString = type ShortString; + PNewhortString = ^TNewhortString; + + TMyWideString = WideString; + PMyWideString = ^TMyWideString; + PPMyWideString = ^PMyWideString; + + TNewWideString = type WideString; + PNewWideString = ^TNewWideString; + + TMyString10 = String[10]; + PMyString10 = ^TMyString10; + PPMyString10 = ^PMyString10; + + + { simple } + { variants } + { Array } + + + + + +procedure FooFunc( + (*** parameter and var-param ***) + { records } + ArgTRec: TRec; var VArgTRec: TRec; + ArgPRec: PRec; var VArgPRec: PRec; + ArgPPRec: PPRec; var VArgPPRec: PPRec; + ArgTNewRec: TNewRec; var VArgTNewRec: TNewRec; + + { Classes } + ArgTFoo: TFoo; var VArgTFoo: TFoo; + ArgPFoo: PFoo; var VArgPFoo: PFoo; + ArgPPFoo: PPFoo; var VArgPPFoo: PPFoo; + ArgTSamePFoo: TSamePFoo; var VArgTSamePFoo: TSamePFoo; + ArgTNewPFoo: TNewPFoo; var VArgTNewPFoo: TNewPFoo; + + ArgTSameFoo: TSameFoo; var VArgTSameFoo: TSameFoo; + ArgTNewFoo: TNewFoo; var VArgTNewFoo: TNewFoo; + ArgPNewFoo: PNewFoo; var VArgPNewFoo: PNewFoo; + + { ClassesTyps } + ArgTFooClass: TFooClass; var VArgTFooClass: TFooClass; + ArgPFooClass: PFooClass; var VArgPFooClass: PFooClass; + ArgPPFooClass: PPFooClass; var VArgPPFooClass: PPFooClass; + ArgTNewFooClass: TNewFooClass; var VArgTNewFooClass: TNewFooClass; + ArgPNewFooClass: PNewFooClass; var VArgPNewFooClass: PNewFooClass; + + { strings } + ArgTMyAnsiString: TMyAnsiString; var VArgTMyAnsiString: TMyAnsiString; + ArgPMyAnsiString: PMyAnsiString; var VArgPMyAnsiString: PMyAnsiString; + ArgPPMyAnsiString: PPMyAnsiString; var VArgPPMyAnsiString: PPMyAnsiString; + + ArgTNewAnsiString: TNewAnsiString; var VArgTNewAnsiString: TNewAnsiString; + ArgPNewAnsiString: PNewAnsiString; var VArgPNewAnsiString: PNewAnsiString; + + + ArgTMyShortString: TMyShortString; var VArgTMyShortString: TMyShortString; + ArgPMyShortString: PMyShortString; var VArgPMyShortString: PMyShortString; + ArgPPMyShortString: PPMyShortString; var VArgPPMyShortString: PPMyShortString; + + ArgTNewhortString: TNewhortString; var VArgTNewhortString: TNewhortString; + ArgPNewhortString: PNewhortString; var VArgPNewhortString: PNewhortString; + + ArgTMyWideString: TMyWideString; var VArgTMyWideString: TMyWideString; + ArgPMyWideString: PMyWideString; var VArgPMyWideString: PMyWideString; + ArgPPMyWideString: PPMyWideString; var VArgPPMyWideString: PPMyWideString; + + ArgTNewWideString: TNewWideString; var VArgTNewWideString: TNewWideString; + ArgPNewWideString: PNewWideString; var VArgPNewWideString: PNewWideString; + + ArgTMyString10: TMyString10; var VArgTMyString10: TMyString10; + ArgPMyString10: PMyString10; var VArgPMyString10: PMyString10; + ArgPPMyString10: PPMyString10; var VArgPPMyString10: PPMyString10; + + { simple } + + ArgByte: Byte; var VArgByte: Byte; + ArgWord: Word; var VArgWord: Word; + ArgLongWord: LongWord; var VArgLongWord: LongWord; + ArgQWord: QWord; var VArgQWord: QWord; + + ArgShortInt: ShortInt; var VArgShortInt: ShortInt; + ArgSmallInt: SmallInt; var VArgSmallInt: SmallInt; + ArgInt: Integer; var VArgInt: Integer; + ArgInt64: Int64; var VArgInt64: Int64; + + ArgPByte: PByte; var VArgPByte: PByte; + ArgPWord: PWord; var VArgPWord: PWord; + ArgPLongWord: PLongWord; var VArgPLongWord: PLongWord; + ArgPQWord: PQWord; var VArgPQWord: PQWord; + + ArgPShortInt: PShortInt; var VArgPShortInt: PShortInt; + ArgPSmallInt: PSmallInt; var VArgPSmallInt: PSmallInt; + ArgPInt: PInteger; var VArgPInt: PInteger; + ArgPInt64: PInt64; var VArgPInt64: PInt64; + + ArgPointer: Pointer; var VArgPointer: Pointer; + ArgPPointer: PPointer; var VArgPPointer: PPointer; + + ArgDouble: Double; var VArgDouble: Double; + ArgExtended: Extended; var VArgExtended: Extended; + + Dummy: Integer ); var - TestInt: Integer; - TesTShortString: String[10]; - TestAnsiString: AnsiString; - TestPChar: PChar; + (*** local var ***) + { records } + VarTRec: TRec; + VarPRec: PRec; + VarPPRec: PPRec; + VarTNewRec: TNewRec; + + PVarTRec: ^TRec; + PVarTNewRec: ^TNewRec; + + { Classes } + VarTFoo: TFoo; + VarPFoo: PFoo; + VarPPFoo: PPFoo; + VarTSamePFoo: TSamePFoo; + VarTNewPFoo: TNewPFoo; + + VarTSameFoo: TSameFoo; + VarTNewFoo: TNewFoo; + VarPNewFoo: PNewFoo; + + PVarTFoo: ^TFoo; + PVarPFoo: ^PFoo; + PVarTSamePFoo: ^TSamePFoo; + PVarTSameFoo: ^TSameFoo; + + { ClassesTyps } + VarTFooClass: TFooClass; + VarPFooClass: PFooClass; + VarPPFooClass: PPFooClass; + VarTNewFooClass: TNewFooClass; + VarPNewFooClass: PNewFooClass; + + PVarTFooClass: ^TFooClass; + + { strings } + VarTMyAnsiString: TMyAnsiString; + VarPMyAnsiString: PMyAnsiString; + VarPPMyAnsiString: PPMyAnsiString; + + VarTNewAnsiString: TNewAnsiString; + VarPNewAnsiString: PNewAnsiString; + + VarTMyShortString: TMyShortString; + VarPMyShortString: PMyShortString; + VarPPMyShortString: PPMyShortString; + + VarTNewhortString: TNewhortString; + VarPNewhortString: PNewhortString; + + VarTMyWideString: TMyWideString; + VarPMyWideString: PMyWideString; + VarPPMyWideString: PPMyWideString; + + VarTNewWideString: TNewWideString; + VarPNewWideString: PNewWideString; + + VarTMyString10: TMyString10; + VarPMyString10: PMyString10; + VarPPMyString10: PPMyString10; + + PVarAnsiString: ^AnsiString; + PVarShortString: ^ShortString; + PVarWideString: ^WideString; + + VarString15: string[15]; + + { simple } + + VarByte: Byte; + VarWord: Word; + VarLongWord: LongWord; + VarQWord: QWord; + + VarShortInt: ShortInt; + varSmallInt: SmallInt; + VarInt: Integer; + VarInt64: Int64; + + VarPByte: PByte; + VarPWord: PWord; + VarPLongWord: PLongWord; + VarPQWord: PQWord; + + VarPShortInt: PShortInt; + varPSmallInt: PSmallInt; + VarPInt: PInteger; + VarPInt64: PInt64; + + PVarByte: ^Byte; + PVarWord: ^Word; + PVarLongWord: ^LongWord; + PVarQWord: ^QWord; + + PVarShortInt: ^ShortInt; + PvarSmallInt: ^SmallInt; + PVarInt: ^Integer; + PVarInt64: ^Int64; + + VarPointer: Pointer; + VarPPointer: PPointer; + PVarPointer: ^Pointer; + + VarDouble: Double; + VarExtended: Extended; + PVarDouble: ^Double; + PVarExtended: ^Extended; + function SubFoo(var AVal1: Integer; AVal2: Integer) : Integer; begin - AVal1 := 2 * AVal2; - Result := AVal2; - inc(AVal2); // First BreakBoint + writeln(1); end; begin - TestInt := 3; - TesTShortString := IntToStr(TestInt) + ':'; - TestAnsiString := TesTShortString + ' Foo'; - TestPChar := @TestAnsiString[2]; - SubFoo(TestInt, 5); - writeln(TestPChar); - writeln(ArgAnsiString1, ArgAnsiString2, ArgAnsiString3, ArgChar1, ArgChar2, ArgChar3); // breakpoint 2 + { records } + VarTRec := ArgTRec; + VarPRec := ArgPRec; + VarPPRec := ArgPPRec; + VarTNewRec := ArgTNewRec; + + PVarTRec := @ArgTRec; + PVarTNewRec := @ArgTNewRec; + + { Classes } + VarTFoo := ArgTFoo; + VarPFoo := ArgPFoo; + VarPPFoo := ArgPPFoo; + VarTSamePFoo := ArgTSamePFoo; + VarTNewPFoo := ArgTNewPFoo; + + VarTSameFoo := ArgTSameFoo; + VarTNewFoo := ArgTNewFoo; + VarPNewFoo := ArgPNewFoo; + + PVarTFoo := @ArgTFoo; + PVarPFoo := @ArgPFoo; + PVarTSamePFoo := @ArgTSamePFoo; + PVarTSameFoo := @ArgTSameFoo; + + { ClassesTyps } + VarTFooClass := ArgTFooClass; + VarPFooClass := ArgPFooClass; + VarPPFooClass := ArgPPFooClass; + VarTNewFooClass := ArgTNewFooClass; + VarPNewFooClass := ArgPNewFooClass; + + PVarTFooClass := @ArgTFooClass; + + { strings } + VarTMyAnsiString := ArgTMyAnsiString + '-var'; + VarPMyAnsiString := ArgPMyAnsiString; + VarPPMyAnsiString := ArgPPMyAnsiString; + + VarTNewAnsiString := ArgTNewAnsiString + '-var'; + VarPNewAnsiString := ArgPNewAnsiString; + + VarTMyShortString := ArgTMyShortString + '-var'; + VarPMyShortString := ArgPMyShortString; + VarPPMyShortString := ArgPPMyShortString; + + VarTNewhortString := ArgTNewhortString + '-var'; + VarPNewhortString := ArgPNewhortString; + + VarTMyWideString := ArgTMyWideString + '-var'; + VarPMyWideString := ArgPMyWideString; + VarPPMyWideString := ArgPPMyWideString; + + VarTNewWideString := ArgTNewWideString + '-var'; + VarPNewWideString := ArgPNewWideString; + + VarTMyString10 := ArgTMyString10 + '-var'; + VarPMyString10 := ArgPMyString10; + VarPPMyString10 := ArgPPMyString10; + + PVarAnsiString := @ArgTMyAnsiString; + PVarShortString := @ArgTMyShortString; + PVarWideString := @ArgTMyWideString; + + VarString15 := 'T15' +#10#13 + 'L2' + #13 + 'L3' +#10 +'L4'; + + { simple } + + VarByte := ArgByte + 100; + VarWord := ArgWord + 100; + VarLongWord := ArgLongWord + 100; + VarQWord := ArgQWord + 100; + + VarShortInt := ArgShortInt + 100; + VarSmallInt := ArgSmallInt + 100; + VarInt := ArgInt + 100; + VarInt64 := ArgInt64 + 100; + + VarPByte := ArgPByte; + VarPWord := ArgPWord; + VarPLongWord := ArgPLongWord; + VarPQWord := ArgPQWord; + + VarPShortInt := ArgPShortInt; + VarPSmallInt := ArgPSmallInt; + VarPInt := ArgPInt; + VarPInt64 := ArgPInt64; + + PVarByte := @ArgByte; + PVarWord := @ArgWord; + PVarLongWord := @ArgLongWord; + PVarQWord := @ArgQWord; + + PVarShortInt := @ArgShortInt; + PVarSmallInt := @ArgSmallInt; + PVarInt := @ArgInt; + PVarInt64 := @ArgInt64; + + VarPointer := ArgPointer; + VarPPointer := ArgPPointer; + PVarPointer := ArgPointer; + + VarDouble := ArgDouble; + VarExtended := ArgExtended; + PVarDouble := @ArgDouble; + PVarExtended := @ArgExtended; + + + SubFoo(VarInt, VarPInt^); + // break on next line + writeln(1); end; + + (*** global var (to feed var-param)-***) var - a2: ansistring; - c2: Char; + { records } + GlobTRec, GlobTRec1, GlobTRec2: TRec; + GlobPRec: PRec; + GlobPPRec: PPRec; + GlobTNewRec: TNewRec; + + PGlobTRec: ^TRec; + PGlobTNewRec: ^TNewRec; + + { 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; + GlobPPFooClass: PPFooClass; + GlobTNewFooClass: TNewFooClass; + GlobPNewFooClass: PNewFooClass; + + PGlobTFooClass: ^TFooClass; + + { strings } + GlobTMyAnsiString: TMyAnsiString; + GlobPMyAnsiString: PMyAnsiString; + GlobPPMyAnsiString: PPMyAnsiString; + + GlobTNewAnsiString: TNewAnsiString; + GlobPNewAnsiString: PNewAnsiString; + + GlobTMyShortString: TMyShortString; + GlobPMyShortString: PMyShortString; + GlobPPMyShortString: PPMyShortString; + + GlobTNewhortString: TNewhortString; + GlobPNewhortString: PNewhortString; + + GlobTMyWideString: TMyWideString; + GlobPMyWideString: PMyWideString; + GlobPPMyWideString: PPMyWideString; + + GlobTNewWideString: TNewWideString; + GlobPNewWideString: PNewWideString; + + GlobTMyString10: TMyString10; + GlobPMyString10: PMyString10; + GlobPPMyString10: PPMyString10; + + PGlobAnsiString: ^AnsiString; + PGlobShortString: ^ShortString; + PGlobWideString: ^WideString; + + GlobString15: string[15]; + + { simple } + + GlobByte: Byte; + GlobWord: Word; + GlobLongWord: LongWord; + GlobQWord: QWord; + + GlobShortInt: ShortInt; + GlobSmallInt: SmallInt; + GlobInt: Integer; + GlobInt64: Int64; + + GlobPByte: PByte; + GlobPWord: PWord; + GlobPLongWord: PLongWord; + GlobPQWord: PQWord; + + GlobPShortInt: PShortInt; + GlobPSmallInt: PSmallInt; + GlobPInt: PInteger; + GlobPInt64: PInt64; + + PGlobByte: ^Byte; + PGlobWord: ^Word; + PGlobLongWord: ^LongWord; + PGlobQWord: ^QWord; + + PGlobShortInt: ^ShortInt; + PGlobSmallInt: ^SmallInt; + PGlobInt: ^Integer; + PGlobInt64: ^Int64; + + GlobPointer: Pointer; + GlobPPointer: PPointer; + PGlobPointer: ^Pointer; + + GlobDouble: Double; + GlobExtended: Extended; + PGlobDouble: ^Double; + PGlobExtended: ^Extended; + begin - a2 := 'def'; - c2 := 'Y'; - Foo('abc', a2, 'ghi', 'X', c2, 'Z'); + { records } + GlobTRec.ValInt := -1; + GlobTRec.ValFoo := nil; + GlobTRec1.ValInt := 1; + GlobTRec1.ValFoo := TFoo.Create; + GlobTRec1.ValFoo.ValueInt := 11; + GlobTRec2.ValInt := 2; + GlobTRec2.ValFoo := TFoo.Create; + GlobTRec2.ValFoo.ValueInt := 22; + + GlobPRec := @GlobTRec1; + GlobPPRec := @GlobPRec; + GlobTNewRec.ValInt := 3; + GlobTNewRec.ValFoo := nil; + + PGlobTRec := @GlobTNewRec; + PGlobTNewRec := @GlobTNewRec; + + { Classes } + GlobTFoo := TFoo.Create; + GlobTFoo.ValueInt := -11; + 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; + GlobPPFooClass := @GlobPFooClass; + GlobTNewFooClass := TNewFoo; + GlobPNewFooClass := @GlobTNewFooClass; + + PGlobTFooClass := @GlobTNewFooClass; + + { strings } + GlobTMyAnsiString := 'ansi'; + GlobPMyAnsiString := @GlobTMyAnsiString; + GlobPPMyAnsiString := @GlobPMyAnsiString; + + GlobTNewAnsiString := 'newansi'; + GlobPNewAnsiString := @GlobTNewAnsiString; + + GlobTMyShortString := 'short'; + GlobPMyShortString := @GlobTMyShortString; + GlobPPMyShortString := @GlobPMyShortString; + + GlobTNewhortString := 'newshort'; + GlobPNewhortString := @GlobTNewhortString; + + GlobTMyWideString := 'wide'; + GlobPMyWideString := @GlobTMyWideString; + GlobPPMyWideString := @GlobPMyWideString; + + GlobTNewWideString := 'newwide'; + GlobPNewWideString := @GlobTNewWideString; + + GlobTMyString10 := 's10'; + GlobPMyString10 := @GlobTMyString10; + GlobPPMyString10 := @GlobPMyString10; + + PGlobAnsiString := @GlobTMyAnsiString; + PGlobShortString := @PGlobAnsiString; + PGlobWideString := @PGlobShortString; + + GlobString15 := 'g15'; + + { simple } + + GlobByte := 25; + GlobWord := 26; + GlobLongWord := 27; + GlobQWord := 28; + + GlobShortInt := 35; + GlobSmallInt := 36; + GlobInt := 37; + GlobInt64 := 38; + + GlobPByte := @GlobByte; + GlobPWord := @GlobWord; + GlobPLongWord := @GlobLongWord; + GlobPQWord := @GlobQWord; + + GlobPShortInt := @GlobShortInt; + GlobPSmallInt := @GlobSmallInt; + GlobPInt := @GlobInt; + GlobPInt64 := @GlobInt64; + + PGlobByte := @GlobByte; + PGlobWord := @GlobWord; + PGlobLongWord := @GlobLongWord; + PGlobQWord := @GlobQWord; + + PGlobShortInt := @GlobShortInt; + PGlobSmallInt := @GlobSmallInt; + PGlobInt := @GlobInt; + PGlobInt64 := @GlobInt64; + + GlobPointer := @GlobByte; + GlobPPointer := @GlobPointer; + PGlobPointer := @GlobPointer; + + GlobDouble := 1.123; + GlobExtended := 2.345; + PGlobDouble := @GlobDouble; + PGlobExtended := @GlobExtended; + + + + + FooFunc( + { records } + GlobTRec, GlobTRec, + GlobPRec, GlobPRec, + GlobPPRec, GlobPPRec, + GlobTNewRec, GlobTNewRec, + + { Classes } + GlobTFoo, GlobTFoo, + GlobPFoo, GlobPFoo, + GlobPPFoo, GlobPPFoo, + GlobTSamePFoo, GlobTSamePFoo, + GlobTNewPFoo, GlobTNewPFoo, + + GlobTSameFoo, GlobTSameFoo, + GlobTNewFoo, GlobTNewFoo, + GlobPNewFoo, GlobPNewFoo, + + { ClassesTyps } + GlobTFooClass, GlobTFooClass, + GlobPFooClass, GlobPFooClass, + GlobPPFooClass, GlobPPFooClass, + GlobTNewFooClass, GlobTNewFooClass, + GlobPNewFooClass, GlobPNewFooClass, + + { strings } + GlobTMyAnsiString, GlobTMyAnsiString, + GlobPMyAnsiString, GlobPMyAnsiString, + GlobPPMyAnsiString, GlobPPMyAnsiString, + + GlobTNewAnsiString, GlobTNewAnsiString, + GlobPNewAnsiString, GlobPNewAnsiString, + + + GlobTMyShortString, GlobTMyShortString, + GlobPMyShortString, GlobPMyShortString, + GlobPPMyShortString, GlobPPMyShortString, + + GlobTNewhortString, GlobTNewhortString, + GlobPNewhortString, GlobPNewhortString, + + GlobTMyWideString, GlobTMyWideString, + GlobPMyWideString, GlobPMyWideString, + GlobPPMyWideString, GlobPPMyWideString, + + GlobTNewWideString, GlobTNewWideString, + GlobPNewWideString, GlobPNewWideString, + + GlobTMyString10, GlobTMyString10, + GlobPMyString10, GlobPMyString10, + GlobPPMyString10, GlobPPMyString10, + + { simple } + + GlobByte, GlobByte, + GlobWord, GlobWord, + GlobLongWord, GlobLongWord, + GlobQWord, GlobQWord, + + GlobShortInt, GlobShortInt, + GlobSmallInt, GlobSmallInt, + GlobInt, GlobInt, + GlobInt64, GlobInt64, + + GlobPByte, GlobPByte, + GlobPWord, GlobPWord, + GlobPLongWord, GlobPLongWord, + GlobPQWord, GlobPQWord, + + GlobPShortInt, GlobPShortInt, + GlobPSmallInt, GlobPSmallInt, + GlobPInt, GlobPInt, + GlobPInt64, GlobPInt64, + + GlobPointer, GlobPointer, + GlobPPointer, GlobPPointer, + + GlobDouble, GlobDouble, + GlobExtended, GlobExtended, + + 0 + ); + + // same with nil + { records } + //GlobTRec := nil; + GlobPRec := nil; + GlobPPRec := nil; + //GlobTNewRec := nil; + + { Classes } + GlobTFoo := nil; + GlobPFoo := nil; + GlobPPFoo := nil; + GlobTSamePFoo := nil; + GlobTNewPFoo := nil; + + GlobTSameFoo := nil; + GlobTNewFoo := nil; + GlobPNewFoo := nil; + + { ClassesTyps } + GlobTFooClass := nil; + GlobPFooClass := nil; + GlobPPFooClass := nil; + GlobTNewFooClass := nil; + GlobPNewFooClass := nil; + + { strings } + GlobTMyAnsiString := ''; + GlobPMyAnsiString := nil; + GlobPPMyAnsiString := nil; + + GlobTNewAnsiString := ''; + GlobPNewAnsiString := nil; + + + GlobTMyShortString := ''; + GlobPMyShortString := nil; + GlobPPMyShortString := nil; + + GlobTNewhortString := ''; + GlobPNewhortString := nil; + + GlobTMyWideString := ''; + GlobPMyWideString := nil; + GlobPPMyWideString := nil; + + GlobTNewWideString := ''; + GlobPNewWideString := nil; + + GlobTMyString10 := ''; + GlobPMyString10 := nil; + GlobPPMyString10 := nil; + + { simple } + + GlobByte := 0; + GlobWord := 0; + GlobLongWord := 0; + GlobQWord := 0; + + GlobShortInt := 0; + GlobSmallInt := 0; + GlobInt := 0; + GlobInt64 := 0; + + GlobPByte := nil; + GlobPWord := nil; + GlobPLongWord := nil; + GlobPQWord := nil; + + GlobPShortInt := nil; + GlobPSmallInt := nil; + GlobPInt := nil; + GlobPInt64 := nil; + + GlobPointer := nil; + GlobPPointer := nil; + + GlobDouble := 0; + GlobExtended := 0; + + + FooFunc( + { records } + GlobTRec, GlobTRec, + GlobPRec, GlobPRec, + GlobPPRec, GlobPPRec, + GlobTNewRec, GlobTNewRec, + + { Classes } + GlobTFoo, GlobTFoo, + GlobPFoo, GlobPFoo, + GlobPPFoo, GlobPPFoo, + GlobTSamePFoo, GlobTSamePFoo, + GlobTNewPFoo, GlobTNewPFoo, + + GlobTSameFoo, GlobTSameFoo, + GlobTNewFoo, GlobTNewFoo, + GlobPNewFoo, GlobPNewFoo, + + { ClassesTyps } + GlobTFooClass, GlobTFooClass, + GlobPFooClass, GlobPFooClass, + GlobPPFooClass, GlobPPFooClass, + GlobTNewFooClass, GlobTNewFooClass, + GlobPNewFooClass, GlobPNewFooClass, + + { strings } + GlobTMyAnsiString, GlobTMyAnsiString, + GlobPMyAnsiString, GlobPMyAnsiString, + GlobPPMyAnsiString, GlobPPMyAnsiString, + + GlobTNewAnsiString, GlobTNewAnsiString, + GlobPNewAnsiString, GlobPNewAnsiString, + + + GlobTMyShortString, GlobTMyShortString, + GlobPMyShortString, GlobPMyShortString, + GlobPPMyShortString, GlobPPMyShortString, + + GlobTNewhortString, GlobTNewhortString, + GlobPNewhortString, GlobPNewhortString, + + GlobTMyWideString, GlobTMyWideString, + GlobPMyWideString, GlobPMyWideString, + GlobPPMyWideString, GlobPPMyWideString, + + GlobTNewWideString, GlobTNewWideString, + GlobPNewWideString, GlobPNewWideString, + + GlobTMyString10, GlobTMyString10, + GlobPMyString10, GlobPMyString10, + GlobPPMyString10, GlobPPMyString10, + + { simple } + + GlobByte, GlobByte, + GlobWord, GlobWord, + GlobLongWord, GlobLongWord, + GlobQWord, GlobQWord, + + GlobShortInt, GlobShortInt, + GlobSmallInt, GlobSmallInt, + GlobInt, GlobInt, + GlobInt64, GlobInt64, + + GlobPByte, GlobPByte, + GlobPWord, GlobPWord, + GlobPLongWord, GlobPLongWord, + GlobPQWord, GlobPQWord, + + GlobPShortInt, GlobPShortInt, + GlobPSmallInt, GlobPSmallInt, + GlobPInt, GlobPInt, + GlobPInt64, GlobPInt64, + + GlobPointer, GlobPointer, + GlobPPointer, GlobPPointer, + + GlobDouble, GlobDouble, + GlobExtended, GlobExtended, + + 0 + ); + + + + // no bother freeing mem end. diff --git a/debugger/test/Gdbmi/testbase.pas b/debugger/test/Gdbmi/testbase.pas index be4463212a..cddf218c8d 100644 --- a/debugger/test/Gdbmi/testbase.pas +++ b/debugger/test/Gdbmi/testbase.pas @@ -102,38 +102,24 @@ type TCompilerSuite = class(TTestSuite) private FCompilerInfo: TCompilerInfo; - public - constructor Create(ACompilerInfo: TCompilerInfo; ADebuggerList: TDebuggerList); - procedure RegisterDbgTest(ATestClass: TTestCaseClass); - public - property CompilerInfo: TCompilerInfo read FCompilerInfo; - end; - - { TCompilerOptionsSuite } - - TCompilerOptionsSuite = class(TTestSuite) - private - FParent: TCompilerSuite; FSymbolSwitch: String; FSymbolType: TSymbolType; FFileNameExt: String; FCompiledList: TStringList; FInRun: Boolean; - function GetCompilerInfo: TCompilerInfo; protected procedure Clear; public - constructor Create(AParent: TCompilerSuite; ASymbolType: TSymbolType; ADebuggerList: TDebuggerList); + constructor Create(ACompilerInfo: TCompilerInfo; ASymbolType: TSymbolType; ADebuggerList: TDebuggerList); destructor Destroy; override; procedure Run(AResult: TTestResult); override; procedure RunTest(ATest: TTest; AResult: TTestResult); override; procedure RegisterDbgTest(ATestClass: TTestCaseClass); Procedure TestCompile(const PrgName: string; out ExeName: string); public - property Parent: TCompilerSuite read FParent; property SymbolType: TSymbolType read FSymbolType; property SymbolSwitch: String read FSymbolSwitch; - property CompilerInfo: TCompilerInfo read GetCompilerInfo; + property CompilerInfo: TCompilerInfo read FCompilerInfo; end; { TDebuggerSuite } @@ -141,15 +127,15 @@ type TDebuggerSuite = class(TTestSuite) private FDebuggerInfo: TDebuggerInfo; - FParent: TCompilerOptionsSuite; + FParent: TCompilerSuite; function GetCompilerInfo: TCompilerInfo; function GetSymbolType: TSymbolType; public - constructor Create(AParent: TCompilerOptionsSuite; ADebuggerInfo: TDebuggerInfo); + constructor Create(AParent: TCompilerSuite; ADebuggerInfo: TDebuggerInfo); procedure RegisterDbgTest(ATestClass: TTestCaseClass); Procedure TestCompile(const PrgName: string; out ExeName: string); public - property Parent: TCompilerOptionsSuite read FParent; + property Parent: TCompilerSuite read FParent; property DebuggerInfo: TDebuggerInfo read FDebuggerInfo; property SymbolType: TSymbolType read GetSymbolType; property CompilerInfo: TCompilerInfo read GetCompilerInfo; @@ -199,6 +185,7 @@ procedure RegisterDbgTest(ATestClass: TTestCaseClass); var AppDir: String; + ConfDir: String; implementation @@ -226,30 +213,24 @@ end; function GetCompilers: TCompilerList; -var - AppDir: String; begin if Compilers <> nil then exit(Compilers); - AppDir := ExtractFilePath(Paramstr(0)); Result := TCompilerList.Create; - if FileExists(AppDir + 'fpclist.txt') then - Result.LoadFromFile(AppDir + 'fpclist.txt'); + if FileExists(ConfDir + 'fpclist.txt') then + Result.LoadFromFile(ConfDir + 'fpclist.txt'); if (Result.Count = 0) and (EnvironmentOptions.CompilerFilename <> '') then Result.Add('fpc from conf', EnvironmentOptions.CompilerFilename); Compilers := Result; end; function GetDebuggers: TDebuggerList; -var - AppDir: String; begin if Debuggers <> nil then exit(Debuggers); - AppDir := ExtractFilePath(Paramstr(0)); Result := TDebuggerList.Create; - if FileExists(AppDir + 'gdblist.txt') then - Result.LoadFromFile(AppDir + 'gdblist.txt'); + if FileExists(ConfDir + 'gdblist.txt') then + Result.LoadFromFile(ConfDir + 'gdblist.txt'); if (Result.Count = 0) and (EnvironmentOptions.DebuggerFilename <> '') then Result.Add('gdb from conf', EnvironmentOptions.DebuggerFilename); Debuggers := Result; @@ -415,40 +396,7 @@ end; { TCompilerSuite } -constructor TCompilerSuite.Create(ACompilerInfo: TCompilerInfo; ADebuggerList: TDebuggerList); -var - st: TSymbolType; - SubSuite: TCompilerOptionsSuite; -begin - inherited Create(ACompilerInfo.Name); - FCompilerInfo := ACompilerInfo; - - for st := low(TSymbolType) to high(TSymbolType) do begin - if not (st in FCompilerInfo.SymbolTypes) then - continue; - - SubSuite := TCompilerOptionsSuite.Create(Self, st, ADebuggerList); - Self.AddTest(SubSuite); - end; -end; - -procedure TCompilerSuite.RegisterDbgTest(ATestClass: TTestCaseClass); -var - i: Integer; -begin - for i := 0 to Tests.Count - 1 do - if Test[i] is TCompilerOptionsSuite then - TCompilerOptionsSuite(Test[i]).RegisterDbgTest(ATestClass); -end; - -{ TCompilerOptionsSuite } - -function TCompilerOptionsSuite.GetCompilerInfo: TCompilerInfo; -begin - Result := Parent.CompilerInfo; -end; - -procedure TCompilerOptionsSuite.Clear; +procedure TCompilerSuite.Clear; var i: Integer; begin @@ -457,14 +405,14 @@ begin FCompiledList.Clear; end; -constructor TCompilerOptionsSuite.Create(AParent: TCompilerSuite; ASymbolType: TSymbolType; +constructor TCompilerSuite.Create(ACompilerInfo: TCompilerInfo; ASymbolType: TSymbolType; ADebuggerList: TDebuggerList); var i: Integer; SubSuite: TDebuggerSuite; begin - inherited Create(SymbolTypeNames[ASymbolType]); - FParent := AParent; + inherited Create(ACompilerInfo.Name + ' / ' + SymbolTypeNames[ASymbolType]); + FCompilerInfo := ACompilerInfo; FSymbolType := ASymbolType; FCompiledList := TStringList.Create; @@ -489,14 +437,14 @@ begin end; end; -destructor TCompilerOptionsSuite.Destroy; +destructor TCompilerSuite.Destroy; begin inherited Destroy; Clear; FreeAndNil(FCompiledList); end; -procedure TCompilerOptionsSuite.Run(AResult: TTestResult); +procedure TCompilerSuite.Run(AResult: TTestResult); begin FInRun := True; try @@ -507,7 +455,7 @@ begin end; end; -procedure TCompilerOptionsSuite.RunTest(ATest: TTest; AResult: TTestResult); +procedure TCompilerSuite.RunTest(ATest: TTest; AResult: TTestResult); begin try inherited RunTest(ATest, AResult); @@ -516,7 +464,7 @@ begin end; end; -procedure TCompilerOptionsSuite.RegisterDbgTest(ATestClass: TTestCaseClass); +procedure TCompilerSuite.RegisterDbgTest(ATestClass: TTestCaseClass); var i: Integer; begin @@ -525,7 +473,7 @@ begin TDebuggerSuite(Test[i]).RegisterDbgTest(ATestClass); end; -procedure TCompilerOptionsSuite.TestCompile(const PrgName: string; out ExeName: string); +procedure TCompilerSuite.TestCompile(const PrgName: string; out ExeName: string); var ExePath, ErrMsg: String; begin @@ -561,10 +509,10 @@ begin Result := Parent.SymbolType; end; -constructor TDebuggerSuite.Create(AParent: TCompilerOptionsSuite; +constructor TDebuggerSuite.Create(AParent: TCompilerSuite; ADebuggerInfo: TDebuggerInfo); begin - inherited Create(ADebuggerInfo.Name); + inherited Create(ADebuggerInfo.Name + ' ('+AParent.TestName+')'); FParent := AParent; FDebuggerInfo := ADebuggerInfo; end; @@ -637,21 +585,28 @@ var GdbList: TDebuggerList; CompilerSuite: TCompilerSuite; i: Integer; + st: TSymbolType; begin FpcList := GetCompilers; GdbList := GetDebuggers; for i := 0 to FpcList.Count - 1 do begin - CompilerSuite := TCompilerSuite.Create(FpcList.CompilerInfo[i], GdbList); - GetTestRegistry.AddTest(CompilerSuite); + for st := low(TSymbolType) to high(TSymbolType) do begin + if not (st in FpcList.CompilerInfo[i].SymbolTypes) then + continue; + + CompilerSuite := TCompilerSuite.Create(FpcList.CompilerInfo[i], st, GdbList); + if CompilerSuite.Tests.Count >0 then + GetTestRegistry.AddTest(CompilerSuite) + else + CompilerSuite.Free; + end; end; end; function CheckAppDir(var AppDir: string): Boolean; begin Result := DirectoryExistsUTF8(AppDir + 'TestApps'); - if Result then - AppDir := AppendPathDelim(AppDir + 'TestApps'); end; function CheckAppDirLib(var AppDir: string): Boolean; @@ -664,7 +619,7 @@ begin s := copy(AppDir, 1, length(AppDir) - length('lib' + DirectorySeparator)); Result := DirectoryExistsUTF8(s + 'TestApps'); if Result then - AppDir := AppendPathDelim(s + 'TestApps'); + AppDir := s; end; end; @@ -694,7 +649,8 @@ initialization Free; end; end; - + ConfDir := AppDir; + AppDir := AppendPathDelim(AppDir + 'TestApps'); EnvironmentOptions := TEnvironmentOptions.Create; with EnvironmentOptions do @@ -702,6 +658,7 @@ initialization SetLazarusDefaultFilename; Load(false); end; + BuildTestSuites; finalization diff --git a/debugger/test/Gdbmi/testwatches.pas b/debugger/test/Gdbmi/testwatches.pas index 0c19bb8552..1407ceb57d 100644 --- a/debugger/test/Gdbmi/testwatches.pas +++ b/debugger/test/Gdbmi/testwatches.pas @@ -6,7 +6,7 @@ interface uses Classes, SysUtils, fpcunit, testutils, testregistry, - TestBase, Debugger, GDBMIDebugger, LCLProc; + TestBase, Debugger, GDBMIDebugger, LCLProc, SynRegExpr; type @@ -18,8 +18,10 @@ type FHasValue: Boolean; FMaster: TDBGWatch; FValue: String; + FTypeInfo: TDBGType; protected procedure DoChanged; override; + function GetTypeInfo: TDBGType; override; public constructor Create(AOwner: TBaseWatches; AMaster: TDBGWatch); property Master: TDBGWatch read FMaster; @@ -33,21 +35,6 @@ type TTestWatches = class(TGDBTestCase) private FWatches: TBaseWatches; - - FAVal1Watch: TTestWatch; - FAVal2Watch: TTestWatch; - - FTestIntWatch: TTestWatch; - FTestShortStringWatch: TTestWatch; - FTestAnsiStringWatch: TTestWatch; - FTestPCharWatch: TTestWatch; - - FArgAnsisString1: TTestWatch; - FArgAnsisString2: TTestWatch; - FArgAnsisString3: TTestWatch; - FArgChar1: TTestWatch; - FArgChar2: TTestWatch; - FArgChar3: TTestWatch; public procedure DebugInteract(dbg: TGDBMIDebugger); @@ -58,21 +45,238 @@ type implementation +const + RNoPreQuote = '(^|[^''])'; // No open qoute (Either at start, or other char) + RNoPostQuote = '($|[^''])'; // No close qoute (Either at end, or other char) + +type + TWatchExpectationFlag = (fnoDwrf, fnoStabs, fTpMtch); + TWatchExpectationFlags = set of TWatchExpectationFlag; + TWatchExpectation = record + Exp: string; + Mtch: string; + Kind: TDBGSymbolKind; + TpNm: string; + Flgs: TWatchExpectationFlags; + end; + +const + Match_Pointer = '(0x|\$)[0-9A-F]+'; + Match_PasPointer = '\$[0-9A-F]+'; + Match_ArgTRec = 'record TREC .+ valint = -1.+valfoo'; // record TREC { VALINT = -1, VALFOO = $0} + Match_ArgTRec1 = 'record TREC .+ valint = 1.+valfoo'; // record TREC { VALINT = 1, VALFOO = $xxx} + Match_ArgTRec2 = 'record TREC .+ valint = 2.+valfoo'; // record TREC { VALINT = 2, VALFOO = $xxx} + Match_ArgTNewRec = 'record TNEWREC .+ valint = 3.+valfoo'; // record TREC { VALINT = 3, VALFOO = $0} + + Match_ArgTFoo = ' = \{.+ValueInt = -1'; + Match_ArgTFoo1 = ' = \{.+ValueInt = 31'; + // Todo: Dwarf fails with dereferenced var pointer types + + ExpectBrk1NoneNil: Array [1..49] of TWatchExpectation = ( + { records } + + (Exp: 'ArgTRec'; Mtch: Match_ArgTRec; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VArgTRec'; Mtch: Match_ArgTRec; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'ArgPRec'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: []), + (Exp: 'VArgPRec'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: []), + (Exp: 'ArgPRec^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VArgPRec^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: [fnoDwrf]), + (Exp: 'ArgPPRec'; Mtch: '^PPRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PPRec'; Flgs: []), + (Exp: 'VArgPPRec'; Mtch: '^PPRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PPRec'; Flgs: []), + (Exp: 'ArgPPRec^'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: []), + (Exp: 'VArgPPRec^'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: [fnoDwrf]), + (Exp: 'ArgPPRec^^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VArgPPRec^^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: [fnoDwrf]), + (Exp: 'ArgTNewRec'; Mtch: Match_ArgTNewRec; Kind: skRecord; TpNm: 'TNewRec'; Flgs: []), + (Exp: 'VArgTNewRec'; Mtch: Match_ArgTNewRec; Kind: skRecord; TpNm: 'TNewRec'; Flgs: []), + + (Exp: 'VarTRec'; Mtch: Match_ArgTRec; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VarPRec'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: []), + (Exp: 'VarPRec^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VarPPRec'; Mtch: '^PPRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PPRec'; Flgs: []), + (Exp: 'VarPPRec^'; Mtch: '^PRec\('+Match_PasPointer; Kind: skPointer; TpNm: 'PRec'; Flgs: []), + (Exp: 'VarPPRec^^'; Mtch: Match_ArgTRec1; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'VarTNewRec'; Mtch: Match_ArgTNewRec; Kind: skRecord; TpNm: 'TNewRec'; Flgs: []), + + (Exp: 'PVarTRec'; Mtch: '^(\^T|P)Rec\('+Match_PasPointer; Kind: skPointer; TpNm: '^(\^T|P)Rec$'; Flgs: [fTpMtch]), // TODO: stabs returns PRec + (Exp: 'PVarTRec^'; Mtch: Match_ArgTRec; Kind: skRecord; TpNm: 'TRec'; Flgs: []), + (Exp: 'PVarTNewRec'; Mtch: '^\^TNewRec\('+Match_PasPointer; Kind: skPointer; TpNm: '^TNewRec'; Flgs: []), + (Exp: 'PVarTNewRec^'; Mtch: Match_ArgTNewRec; Kind: skRecord; TpNm: 'TNewRec'; Flgs: []), + + (Exp: 'ArgTFoo'; Mtch: Match_ArgTFoo; Kind: skClass; TpNm: 'TFoo'; Flgs: []), + (Exp: 'VArgTFoo'; Mtch: Match_ArgTFoo; Kind: skClass; TpNm: 'TFoo'; Flgs: []), + (Exp: 'ArgPFoo'; Mtch: 'PFoo\('+Match_PasPointer; Kind: skPointer; TpNm: 'PFoo'; Flgs: []), + (Exp: 'VArgPFoo'; Mtch: 'PFoo\('+Match_PasPointer; Kind: skPointer; TpNm: 'PFoo'; Flgs: []), + (Exp: 'ArgPFoo^'; Mtch: Match_ArgTFoo1; Kind: skClass; TpNm: 'TFoo'; Flgs: []), + (Exp: 'VArgPFoo^'; Mtch: Match_ArgTFoo1; Kind: skClass; TpNm: 'TFoo'; Flgs: [fnoDwrf]), + + (* + + { Classes } + (Exp: 'ArgPPFoo'; Mtch: ''; Kind: sk; TpNm: 'PPFoo'; Flgs: []), + (Exp: 'VArgPPFoo'; Mtch: ''; Kind: sk; TpNm: 'PPFoo'; Flgs: []), + (Exp: 'ArgTSamePFoo'; Mtch: ''; Kind: sk; TpNm: 'TSamePFoo'; Flgs: []), + (Exp: 'VArgTSamePFoo'; Mtch: ''; Kind: sk; TpNm: 'TSamePFoo'; Flgs: []), + (Exp: 'ArgTNewPFoo'; Mtch: ''; Kind: sk; TpNm: 'TNewPFoo'; Flgs: []), + (Exp: 'VArgTNewPFoo'; Mtch: ''; Kind: sk; TpNm: 'TNewPFoo'; Flgs: []), + + (Exp: 'ArgTSameFoo'; Mtch: ''; Kind: sk; TpNm: 'TSameFoo'; Flgs: []), + (Exp: 'VArgTSameFoo'; Mtch: ''; Kind: sk; TpNm: 'TSameFoo'; Flgs: []), + (Exp: 'ArgTNewFoo'; Mtch: ''; Kind: sk; TpNm: 'TNewFoo'; Flgs: []), + (Exp: 'VArgTNewFoo'; Mtch: ''; Kind: sk; TpNm: 'TNewFoo'; Flgs: []), + (Exp: 'ArgPNewFoo'; Mtch: ''; Kind: sk; TpNm: 'PNewFoo'; Flgs: []), + (Exp: 'VArgPNewFoo'; Mtch: ''; Kind: sk; TpNm: 'PNewFoo'; Flgs: []), + + { ClassesTyps } + (Exp: 'ArgTFooClass'; Mtch: ''; Kind: sk; TpNm: 'TFooClass'; Flgs: []), + (Exp: 'VArgTFooClass'; Mtch: ''; Kind: sk; TpNm: 'TFooClass'; Flgs: []), + (Exp: 'ArgPFooClass'; Mtch: ''; Kind: sk; TpNm: 'PFooClass'; Flgs: []), + (Exp: 'VArgPFooClass'; Mtch: ''; Kind: sk; TpNm: 'PFooClass'; Flgs: []), + (Exp: 'ArgPPFooClass'; Mtch: ''; Kind: sk; TpNm: 'PPFooClass'; Flgs: []), + (Exp: 'VArgPPFooClass'; Mtch: ''; Kind: sk; TpNm: 'PPFooClass'; Flgs: []), + (Exp: 'ArgTNewFooClass'; Mtch: ''; Kind: sk; TpNm: 'TNewFooClass'; Flgs: []), + (Exp: 'VArgTNewFooClass'; Mtch: ''; Kind: sk; TpNm: 'TNewFooClass'; Flgs: []), + (Exp: 'ArgPNewFooClass'; Mtch: ''; Kind: sk; TpNm: 'PNewFooClass'; Flgs: []), + (Exp: 'VArgPNewFooClass'; Mtch: ''; Kind: sk; TpNm: 'PNewFooClass'; Flgs: []), + *) + + { strings } + (Exp: 'ArgTMyAnsiString'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch]), + (Exp: 'VArgTMyAnsiString'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch]), + (Exp: 'ArgPMyAnsiString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PMyAnsiString'; Flgs: []), + (Exp: 'VArgPMyAnsiString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PMyAnsiString'; Flgs: []), + (Exp: 'ArgPMyAnsiString^'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch]), + (Exp: 'VArgPMyAnsiString^'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch, fnoDwrf]), + (Exp: 'ArgPPMyAnsiString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PPMyAnsiString'; Flgs: []), + (Exp: 'VArgPPMyAnsiString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PPMyAnsiString'; Flgs: []), + (Exp: 'ArgPPMyAnsiString^'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PMyAnsiString'; Flgs: []), + (Exp: 'VArgPPMyAnsiString^'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'PMyAnsiString'; Flgs: [fnoDwrf]), + (Exp: 'ArgPPMyAnsiString^^'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch]), + (Exp: 'VArgPPMyAnsiString^^'; Mtch: '''ansi'''; Kind: skPointer; TpNm: '^(TMy)?AnsiString$'; Flgs: [fTpMtch, fnoDwrf]), + + (* + (Exp: 'ArgTNewAnsiString'; Mtch: ''; Kind: sk; TpNm: 'TNewAnsiString'; Flgs: []), + (Exp: 'VArgTNewAnsiString'; Mtch: ''; Kind: sk; TpNm: 'TNewAnsiString'; Flgs: []), + (Exp: 'ArgPNewAnsiString'; Mtch: ''; Kind: sk; TpNm: 'PNewAnsiString'; Flgs: []), + (Exp: 'VArgPNewAnsiString'; Mtch: ''; Kind: sk; TpNm: 'PNewAnsiString'; Flgs: []), + *) + + (Exp: 'ArgTMyShortString'; Mtch: '''short'''; Kind: skSimple; TpNm: '^(TMy)?ShortString$'; Flgs: [fTpMtch]), + (Exp: 'VArgTMyShortString'; Mtch: '''short'''; Kind: skSimple; TpNm: '^(TMy)?ShortString$'; Flgs: [fTpMtch]), + (Exp: 'ArgPMyShortString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'P(My)?ShortString'; Flgs: [fTpMtch]), + (Exp: 'VArgPMyShortString'; Mtch: Match_Pointer; Kind: skPointer; TpNm: 'P(My)?ShortString'; Flgs: [fTpMtch]), + (Exp: 'ArgPMyShortString^'; Mtch: '''short'''; Kind: skSimple; TpNm: '^(TMy)?ShortString$'; Flgs: [fTpMtch]), + (Exp: 'VArgPMyShortString^'; Mtch: '''short'''; Kind: skSimple; TpNm: '^(TMy)?ShortString$'; Flgs: [fTpMtch, fnoDwrf])//, + + (* + (Exp: 'ArgPPMyShortString'; Mtch: ''; Kind: sk; TpNm: 'PPMyShortString'; Flgs: []), + (Exp: 'VArgPPMyShortString'; Mtch: ''; Kind: sk; TpNm: 'PPMyShortString'; Flgs: []), + (Exp: 'ArgTNewhortString'; Mtch: ''; Kind: sk; TpNm: 'TNewhortString'; Flgs: []), + (Exp: 'VArgTNewhortString'; Mtch: ''; Kind: sk; TpNm: 'TNewhortString'; Flgs: []), + (Exp: 'ArgPNewhortString'; Mtch: ''; Kind: sk; TpNm: 'PNewhortString'; Flgs: []), + (Exp: 'VArgPNewhortString'; Mtch: ''; Kind: sk; TpNm: 'PNewhortString'; Flgs: []), + + (Exp: 'ArgTMyWideString'; Mtch: ''; Kind: sk; TpNm: 'TMyWideString'; Flgs: []), + (Exp: 'VArgTMyWideString'; Mtch: ''; Kind: sk; TpNm: 'TMyWideString'; Flgs: []), + (Exp: 'ArgPMyWideString'; Mtch: ''; Kind: sk; TpNm: 'PMyWideString'; Flgs: []), + (Exp: 'VArgPMyWideString'; Mtch: ''; Kind: sk; TpNm: 'PMyWideString'; Flgs: []), + (Exp: 'ArgPPMyWideString'; Mtch: ''; Kind: sk; TpNm: 'PPMyWideString'; Flgs: []), + (Exp: 'VArgPPMyWideString'; Mtch: ''; Kind: sk; TpNm: 'PPMyWideString'; Flgs: []), + + (Exp: 'ArgTNewWideString'; Mtch: ''; Kind: sk; TpNm: 'TNewWideString'; Flgs: []), + (Exp: 'VArgTNewWideString'; Mtch: ''; Kind: sk; TpNm: 'TNewWideString'; Flgs: []), + (Exp: 'ArgPNewWideString'; Mtch: ''; Kind: sk; TpNm: 'PNewWideString'; Flgs: []), + (Exp: 'VArgPNewWideString'; Mtch: ''; Kind: sk; TpNm: 'PNewWideString'; Flgs: []), + + (Exp: 'ArgTMyString10'; Mtch: ''; Kind: sk; TpNm: 'TMyString10'; Flgs: []), + (Exp: 'VArgTMyString10'; Mtch: ''; Kind: sk; TpNm: 'TMyString10'; Flgs: []), + (Exp: 'ArgPMyString10'; Mtch: ''; Kind: sk; TpNm: 'PMyString10'; Flgs: []), + (Exp: 'VArgPMyString10'; Mtch: ''; Kind: sk; TpNm: 'PMyString10'; Flgs: []), + (Exp: 'ArgPPMyString10'; Mtch: ''; Kind: sk; TpNm: 'PPMyString10'; Flgs: []), + (Exp: 'VArgPPMyString10'; Mtch: ''; Kind: sk; TpNm: 'PPMyString10'; Flgs: []), + + { simple } + + (Exp: 'ArgByte'; Mtch: ''; Kind: sk; TpNm: 'Byte'; Flgs: []), + (Exp: 'VArgByte'; Mtch: ''; Kind: sk; TpNm: 'Byte'; Flgs: []), + (Exp: 'ArgWord'; Mtch: ''; Kind: sk; TpNm: 'Word'; Flgs: []), + (Exp: 'VArgWord'; Mtch: ''; Kind: sk; TpNm: 'Word'; Flgs: []), + (Exp: 'ArgLongWord'; Mtch: ''; Kind: sk; TpNm: 'LongWord'; Flgs: []), + (Exp: 'VArgLongWord'; Mtch: ''; Kind: sk; TpNm: 'LongWord'; Flgs: []), + (Exp: 'ArgQWord'; Mtch: ''; Kind: sk; TpNm: 'QWord'; Flgs: []), + (Exp: 'VArgQWord'; Mtch: ''; Kind: sk; TpNm: 'QWord'; Flgs: []), + + (Exp: 'ArgShortInt'; Mtch: ''; Kind: sk; TpNm: 'ShortInt'; Flgs: []), + (Exp: 'VArgShortInt'; Mtch: ''; Kind: sk; TpNm: 'ShortInt'; Flgs: []), + (Exp: 'ArgSmallInt'; Mtch: ''; Kind: sk; TpNm: 'SmallInt'; Flgs: []), + (Exp: 'VArgSmallInt'; Mtch: ''; Kind: sk; TpNm: 'SmallInt'; Flgs: []), + (Exp: 'ArgInt'; Mtch: ''; Kind: sk; TpNm: 'Integer'; Flgs: []), + (Exp: 'VArgInt'; Mtch: ''; Kind: sk; TpNm: 'Integer'; Flgs: []), + (Exp: 'ArgInt64'; Mtch: ''; Kind: sk; TpNm: 'Int64'; Flgs: []), + (Exp: 'VArgInt64'; Mtch: ''; Kind: sk; TpNm: 'Int64'; Flgs: []), + + (Exp: 'ArgPByte'; Mtch: ''; Kind: sk; TpNm: 'PByte'; Flgs: []), + (Exp: 'VArgPByte'; Mtch: ''; Kind: sk; TpNm: 'PByte'; Flgs: []), + (Exp: 'ArgPWord'; Mtch: ''; Kind: sk; TpNm: 'PWord'; Flgs: []), + (Exp: 'VArgPWord'; Mtch: ''; Kind: sk; TpNm: 'PWord'; Flgs: []), + (Exp: 'ArgPLongWord'; Mtch: ''; Kind: sk; TpNm: 'PLongWord'; Flgs: []), + (Exp: 'VArgPLongWord'; Mtch: ''; Kind: sk; TpNm: 'PLongWord'; Flgs: []), + (Exp: 'ArgPQWord'; Mtch: ''; Kind: sk; TpNm: 'PQWord'; Flgs: []), + (Exp: 'VArgPQWord'; Mtch: ''; Kind: sk; TpNm: 'PQWord'; Flgs: []), + + (Exp: 'ArgPShortInt'; Mtch: ''; Kind: sk; TpNm: 'PShortInt'; Flgs: []), + (Exp: 'VArgPShortInt'; Mtch: ''; Kind: sk; TpNm: 'PShortInt'; Flgs: []), + (Exp: 'ArgPSmallInt'; Mtch: ''; Kind: sk; TpNm: 'PSmallInt'; Flgs: []), + (Exp: 'VArgPSmallInt'; Mtch: ''; Kind: sk; TpNm: 'PSmallInt'; Flgs: []), + (Exp: 'ArgPInt'; Mtch: ''; Kind: sk; TpNm: 'PInteger'; Flgs: []), + (Exp: 'VArgPInt'; Mtch: ''; Kind: sk; TpNm: 'PInteger'; Flgs: []), + (Exp: 'ArgPInt64'; Mtch: ''; Kind: sk; TpNm: 'PInt64'; Flgs: []), + (Exp: 'VArgPInt64'; Mtch: ''; Kind: sk; TpNm: 'PInt64'; Flgs: []), + + (Exp: 'ArgPointer'; Mtch: ''; Kind: sk; TpNm: 'Pointer'; Flgs: []), + (Exp: 'VArgPointer'; Mtch: ''; Kind: sk; TpNm: 'Pointer'; Flgs: []), + (Exp: 'ArgPPointer'; Mtch: ''; Kind: sk; TpNm: 'PPointer'; Flgs: []), + (Exp: 'VArgPPointer'; Mtch: ''; Kind: sk; TpNm: 'PPointer'; Flgs: []), + + (Exp: 'ArgDouble'; Mtch: ''; Kind: sk; TpNm: 'Double'; Flgs: []), + (Exp: 'VArgDouble'; Mtch: ''; Kind: sk; TpNm: 'Double'; Flgs: []), + (Exp: 'ArgExtended'; Mtch: ''; Kind: sk; TpNm: 'Extended'; Flgs: []), + (Exp: 'VArgExtended'; Mtch: ''; Kind: sk; TpNm: 'Extended'; Flgs: []), +*) + + ); + + + + + { TTestWatch } procedure TTestWatch.DoChanged; begin + if FMaster = nil then exit;; if FMaster.Valid = vsValid then begin - if FHasValue and (FValue <> FMaster.Value) then + if FHasValue and (FValue <> FMaster.Value) then begin FHasMultiValue := True; + FValue := FValue + LineEnding + FMaster.Value; + end + else + FValue := FMaster.Value; FHasValue := True; - FValue := FMaster.Value; + + FTypeInfo := Master.TypeInfo; end; end; +function TTestWatch.GetTypeInfo: TDBGType; +begin + Result := FTypeInfo; +end; + constructor TTestWatch.Create(AOwner: TBaseWatches; AMaster: TDBGWatch); begin inherited Create(AOwner); + Expression := AMaster.Expression; FMaster := AMaster; FMaster.Slave := Self; FMaster.Enabled := True; @@ -92,61 +296,85 @@ end; procedure TTestWatches.TestWatches; var FailText: String; - procedure TestWatch(Name: String; AWatch: TTestWatch; Exp: String; StripQuotes: Boolean = False); + + procedure TestWatch(Name: String; Data: TWatchExpectation); + const KindName: array [TDBGSymbolKind] of string = + ('skClass', 'skRecord', 'skEnum', 'skSet', 'skProcedure', 'skFunction', 'skSimple', 'skPointer', 'skVariant'); var + AWatch: TTestWatch; + rx: TRegExpr; s: String; begin + rx := nil; + if (fnoDwrf in Data.Flgs) and (SymbolType = stDwarf) then exit; + if (fnoStabs in Data.Flgs) and (SymbolType = stStabs) then exit; + + Name := Name + Data.Exp; + AWatch := TTestWatch(FWatches.Find(Data.Exp)); try AWatch.Master.Value; // trigger read AssertTrue (Name+ ' (HasValue)', AWatch.HasValue); AssertFalse (Name+ ' (One Value)', AWatch.HasMultiValue); + s := AWatch.Value; - if StripQuotes and (length(s) > 1) and - (s[1] = '''') and (s[length(s)] = '''') - then - s := copy(s, 2, length(s)-2); - AssertEquals(Name+ ' (Value)', Exp, s); + rx := TRegExpr.Create; + rx.ModifierI := true; + rx.Expression := Data.Mtch; + if Data.Mtch <> '' + then AssertTrue(Name + ' Matches "'+Data.Mtch + '", but was "' + s + '"', rx.Exec(s)); except on e: Exception do - FailText := FailText + e.Message + LineEnding; + FailText := FailText + LineEnding + e.Message; end; + try + if Data.TpNm <> '' then begin; + AssertTrue(Name + ' has typeinfo', AWatch.TypeInfo <> nil); + AssertEquals(Name + ' kind', KindName[Data.Kind], KindName[AWatch.TypeInfo.Kind]); + if fTpMtch in Data.Flgs + then begin + FreeAndNil(rx); + s := AWatch.TypeInfo.TypeName; + rx := TRegExpr.Create; + rx.ModifierI := true; + rx.Expression := Data.TpNm; + AssertTrue(Name + ' TypeName matches '+Data.TpNm+' but was '+AWatch.TypeInfo.TypeName, rx.Exec(s)) + end + else AssertEquals(Name + ' TypeName', LowerCase(Data.TpNm), LowerCase(AWatch.TypeInfo.TypeName)); + end; + except + on e: Exception do + FailText := FailText + LineEnding + e.Message; + end; + FreeAndNil(rx); end; var TestExeName: string; dbg: TGDBMIDebugger; + i: Integer; begin TestCompile(AppDir + 'WatchesPrg.pas', TestExeName); - FTestIntWatch := nil; try FWatches := TBaseWatches.Create(TBaseWatch); dbg := TGDBMIDebugger.Create(DebuggerInfo.ExeName); - //dbg.OnBreakPointHit := @DebuggerBreakPointHit; - with dbg.BreakPoints.Add('WatchesPrg.pas', 20) do begin - InitialEnabled := True; - Enabled := True; - end; - with dbg.BreakPoints.Add('WatchesPrg.pas', 30) do begin + + (* Add breakpoints *) + //with dbg.BreakPoints.Add('WatchesPrg.pas', 44) do begin + // InitialEnabled := True; + // Enabled := True; + //end; + with dbg.BreakPoints.Add('WatchesPrg.pas', 395) do begin InitialEnabled := True; Enabled := True; end; - FAVal1Watch := TTestWatch.Create(FWatches, dbg.Watches.Add('AVal1')); - FAVal2Watch := TTestWatch.Create(FWatches, dbg.Watches.Add('AVal2')); + (* Create all watches *) + for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do + TTestWatch.Create(FWatches, dbg.Watches.Add(ExpectBrk1NoneNil[i].Exp)); - FTestIntWatch := TTestWatch.Create(FWatches, dbg.Watches.Add('TestInt')); - FTestShortStringWatch := TTestWatch.Create(FWatches, dbg.Watches.Add('TestShortString')); - FTestAnsiStringWatch := TTestWatch.Create(FWatches, dbg.Watches.Add('TestAnsiString')); - FTestPCharWatch := TTestWatch.Create(FWatches, dbg.Watches.Add('TestPChar')); - - FArgAnsisString1 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgAnsiString1')); - FArgAnsisString2 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgAnsiString2')); - FArgAnsisString3 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgAnsiString3')); - FArgChar1 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgChar1')); - FArgChar2 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgChar2')); - FArgChar3 := TTestWatch.Create(FWatches, dbg.Watches.Add('ArgChar3')); + (* Start debugging *) dbg.Init; if dbg.State = dsError then Fail(' Failed Init'); @@ -157,28 +385,15 @@ begin dbg.ShowConsole := True; dbg.Run; - // hit breakpoint - //TestWatch('AVal1', FAVal1Watch, '10'); - TestWatch('AVal2', FAVal2Watch, '5'); - TestWatch('TestInt', FTestIntWatch, '10'); - //TestWatch('TestShortString', FTestShortStringWatch, '3:', True); - TestWatch('TestAnsiString', FTestAnsiStringWatch, '3: Foo', True); - TestWatch('TestPChar', FTestPCharWatch, ': Foo', True); + (* Hit first breakpoint: Test *) + for i := low(ExpectBrk1NoneNil) to high(ExpectBrk1NoneNil) do + TestWatch('Brk1 ', ExpectBrk1NoneNil[i]); dbg.Run; - // 2nd breakpoint - TestWatch('ArgAnsiString1', FArgAnsisString1, 'abc', True); - //TestWatch('ArgAnsiString2', FArgAnsisString2, 'def', True); - TestWatch('ArgAnsiString3', FArgAnsisString3, 'ghi', True); - - TestWatch('ArgChar1', FArgChar1, '88 ''X'''); - //TestWatch('ArgChar2', FArgChar2, '89 ''Y'''); - TestWatch('ArgChar3', FArgChar3, '90 ''Z'''); //DebugInteract(dbg); - dbg.Stop; finally dbg.Free;