148
77
Flags: TGDBPTypeResultFlags;
149
78
Kind: TGDBPTypeResultKind;
150
79
Name, BaseName: TPCharWithLen; // BaseName is without ^&
151
Declaration: TPCharWithLen;
80
BoundLow, BoundHigh: TPCharWithLen;
81
Declaration, BaseDeclaration: TPCharWithLen; // BaseDeclaration only for Array and Set types, see note on ptprfDeclarationInBrackets
82
PointerCount: Integer;
83
// type of array entry, or set-enum
84
SubName, BaseSubName: TPCharWithLen;
85
SubFlags: TGDBPTypeResultFlags;
86
SubKind: TGDBPTypeResultKind;
88
NestArrayCount: Integer;
89
NestArray: array of record // reverse order, last entry is first nest level
90
Flags: TGDBPTypeResultFlags;
91
BoundLow, BoundHigh: TPCharWithLen;
92
PointerCount: Integer;
96
TGDBCommandRequestType = (gcrtPType, gcrtEvalExpr);
154
98
PGDBPTypeRequest = ^TGDBPTypeRequest;
155
99
TGDBPTypeRequest = record
101
ReqType: TGDBCommandRequestType;
157
102
Result: TGDBPTypeResult;
159
104
Next: PGDBPTypeRequest;
108
(* List: "ACount", "+", "1"
110
Cast/Call: "Foo(Bar)"
113
{ TGDBExpressionPart }
115
TGDBExpressionPart = class
117
FText: TPCharWithLen;
118
function GetParts(Index: Integer): TGDBExpressionPart; virtual;
119
function GetTextFixed(AStringFixed: Boolean): String; virtual;
120
function GetText: String;
121
function GetTextStrFixed: String;
122
function ParseExpression(AText: PChar; ATextLen: Integer): TGDBExpressionPart;
123
procedure Init; virtual;
124
procedure InitReq(var AReqPtr: PGDBPTypeRequest; var AReqVar: TGDBPTypeRequest;
125
AReqText: String; AType: TGDBCommandRequestType = gcrtPType);
127
function NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean; virtual;
128
function MayNeedStringFix: Boolean; virtual;
129
function MayNeedTypeCastFix: Boolean; virtual;
132
function IsNamedOperator: Boolean;
133
function PartCount: Integer; virtual;
134
property Parts[Index: Integer]: TGDBExpressionPart read GetParts;
135
property Text: String read GetText;
136
property TextStrFixed: String read GetTextStrFixed;
141
TGDBExpression = class(TGDBExpressionPart)
145
FExpressionPart: TGDBExpressionPart;
146
function GetTextFixed(AStringFixed: Boolean): String; override;
147
function GetParts(Index: Integer): TGDBExpressionPart; override;
149
constructor CreateSimple(AText: PChar; ATextLen: Integer);
150
constructor Create(AText: PChar; ATextLen: Integer); virtual; overload;
151
constructor Create(ATextStr: String); overload;
152
destructor Destroy; override;
153
function PartCount: Integer; override;
154
function IsCommaSeparated: Boolean;
157
{ TGDBExpressionPartBracketed }
159
TGDBExpressionPartBracketed = class(TGDBExpression)
161
function GetTextFixed(AStringFixed: Boolean): String; override;
162
function GetPlainText: String;
164
constructor Create(AText: PChar; ATextLen: Integer); override; overload;
167
{ TGDBExpressionPartListBase }
169
TGDBExpressionPartListBase = class(TGDBExpressionPart)
173
function GetParts(Index: Integer): TGDBExpressionPart; override;
174
function GetTextFixed(AStringFixed: Boolean): String; override;
177
destructor Destroy; override;
179
procedure ClearShared;
180
function Add(APart: TGDBExpressionPart):Integer;
181
procedure Insert(AIndex: Integer; APart: TGDBExpressionPart);
182
procedure Delete(AIndex: Integer);
183
function PartCount: Integer; override;
186
TGDBExpressionPartList = class(TGDBExpressionPartListBase)
188
function AddList(APartList: TGDBExpressionPartList):Integer;
191
{ TGDBExpressionPartCommaList }
193
TGDBExpressionPartCommaList = class(TGDBExpressionPartList)
195
function GetTextFixed(AStringFixed: Boolean): String; override;
198
{ TGDBExpressionPartArrayIdx }
200
TGDBExpressionPartArrayIdx = class(TGDBExpressionPartBracketed)
202
FArrayPTypeNestIdx: integer;
203
FArrayPTypePointerIdx: integer;
204
FPTypeIndexReq: TGDBPTypeRequest;
206
FPTypeReq: TGDBPTypeRequest;
207
FPTypeDeRefReq: TGDBPTypeRequest;
208
function GetArrayPTypeIsDeRef: boolean;
209
function GetArrayPTypeIsPointer: boolean;
210
function GetArrayPTypeResult: TGDBPTypeResult;
212
procedure Init; override;
213
procedure InitReq(var AReqPtr: PGDBPTypeRequest; AReqText: String); overload;
214
procedure InitDeRefReq(var AReqPtr: PGDBPTypeRequest; AReqText: String);
215
procedure InitIndexReq(var AReqPtr: PGDBPTypeRequest);
216
function GetTextFixed(AStringFixed: Boolean): String; override;
217
property VarParam: Boolean read FVarParam write FVarParam;
218
property PTypeReq: TGDBPTypeRequest read FPTypeReq write FPTypeReq;
219
property PTypeDeRefReq: TGDBPTypeRequest read FPTypeDeRefReq write FPTypeDeRefReq;
220
property PTypeIndexReq: TGDBPTypeRequest read FPTypeIndexReq write FPTypeIndexReq;
221
property ArrayPTypeResult: TGDBPTypeResult read GetArrayPTypeResult;
222
property ArrayPTypeIsDeRef: boolean read GetArrayPTypeIsDeRef;
223
property ArrayPTypeIsPointer: boolean read GetArrayPTypeIsPointer;
224
property ArrayPTypeNestIdx: integer read FArrayPTypeNestIdx write FArrayPTypeNestIdx;
225
property ArrayPTypePointerIdx: integer read FArrayPTypePointerIdx write FArrayPTypePointerIdx;
226
// for comma separated
227
function CreateExpressionForSubIndex(AIndex: Integer): TGDBExpressionPartArrayIdx;
230
{ TGDBExpressionPartArray }
232
TGDBExpressionPartArray = class(TGDBExpressionPartListBase)
234
FNeedTypeCast: Boolean;
235
FMaybeString: Boolean;
236
function GetIndexParts(Index: Integer): TGDBExpressionPartArrayIdx;
238
function GetTextFixed(AStringFixed: Boolean): String; override;
239
function GetTextToIdx(AIdx: Integer; AStrFixed: Boolean = False): String;
240
function IndexCount: Integer;
241
property IndexPart[Index: Integer]: TGDBExpressionPartArrayIdx read GetIndexParts;
243
constructor Create(ALeadExpresion: TGDBExpressionPart);
244
function AddIndex(APart: TGDBExpressionPartArrayIdx):Integer;
245
function NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean; override;
246
function MayNeedStringFix: Boolean; override;
247
property NeedTypeCast: Boolean read FNeedTypeCast write FNeedTypeCast;
250
{ TGDBExpressionPartCastCall }
251
TTypeCastFixFlag = (tcfUnknown, tcfEvalNeeded, tcfNoFixNeeded, tcfFixNeeded);
253
TGDBExpressionPartCastCall = class(TGDBExpressionPartListBase)
255
FIsFunction: Boolean;
256
FIsTypeCast: Boolean;
257
FPTypeReq: TGDBPTypeRequest;
258
FTypeCastFixFlag: TTypeCastFixFlag;
260
procedure Init; override;
261
function GetTextFixed(AStringFixed: Boolean): String; override;
262
property PTypeReq: TGDBPTypeRequest read FPTypeReq write FPTypeReq;
264
constructor Create(ALeadExpresion: TGDBExpressionPart);
265
function AddBrackets(APart: TGDBExpressionPart):Integer;
266
function NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean; override;
267
function MayNeedTypeCastFix: Boolean; override;
268
property IsFunction: Boolean read FIsFunction;
269
property IsTypeCast: Boolean read FIsTypeCast;
273
{ TGDBPTypeRequestCacheEntry }
275
TGDBPTypeRequestCacheEntry = class
277
FRequest: TGDBPTypeRequest;
278
FStackFrame: Integer;
281
property ThreadId: Integer read FThreadId;
282
property StackFrame: Integer read FStackFrame;
283
property Request: TGDBPTypeRequest read FRequest;
286
TGDBPTypeRequestCache = class
289
function GetRequest(Index: Integer): TGDBPTypeRequest;
292
destructor Destroy; override;
294
function IndexOf(AThreadId, AStackFrame: Integer; ARequest: TGDBPTypeRequest): Integer;
295
procedure Add(AThreadId, AStackFrame: Integer; ARequest: TGDBPTypeRequest);
296
property Request[Index: Integer]: TGDBPTypeRequest read GetRequest;
164
301
TGDBTypes = class(TDBGTypes)
471
639
Result.BaseName.Len := 0;
472
640
Result.Declaration.Ptr := nil;
473
641
Result.Declaration.Len := 0;
474
If ATypeText = '' then exit;
476
(* // Clean the gdb outpu, remove ~"...."; replace \n by #13
477
if (length(ATypeText) >= 2) and (ATypeText[1] = '~') and (ATypeText[2] = '"') then
478
UniqueString(Result.GdbDescription);
479
CurPtr := @Result.GdbDescription[1];
481
while (EndPtr^ <> #0) do begin
482
if (EndPtr^ = '~') and ((EndPtr+1)^ = '"') then begin
484
while not (EndPtr^ in [#0..#31]) do begin
485
if (EndPtr^ = '\') then begin
488
then CurPtr^ := #13 // internal marker only, no need for OS specific
489
else CurPtr^ := EndPtr^;
497
if CurPtr^ <> '"' then begin
499
debugln('** WARNING: ptype info format error (end-quote): ' + ATypeText);
500
Result.GdbDescription := ATypeText;
501
CurPtr := @Result.GdbDescription[length(Result.GdbDescription)] + 1;
507
debugln('** WARNING: ptype info format error (start-quote): ' + ATypeText);
508
Result.GdbDescription := ATypeText;
509
CurPtr := @Result.GdbDescription[length(Result.GdbDescription)] + 1;
642
Result.BaseDeclaration.Ptr := nil;
643
Result.BaseDeclaration.Len := 0;
644
Result.PointerCount := 0;
645
Result.BoundLow.Ptr := nil;
646
Result.BoundLow.Len := 0;
647
Result.BoundHigh.Ptr := nil;
648
Result.BoundHigh.Len := 0;
649
Result.SubName.Ptr := nil;
650
Result.SubName.Len := 0;
651
Result.BaseSubName.Ptr := nil;
652
Result.BaseSubName.Len := 0;
653
Result.SubFlags := [];
654
Result.SubKind := ptprkError;
655
Result.NestArrayCount := 0;
656
If (ATypeText = nil) or (ATypeTextLen = 0) then exit;
659
type = [&^][name] = class|record : public
660
type = [&^][name] = (a,b,c)
662
type = [&^]set of [name] = (a,b)
669
EndPtr := ATypeText + ATypeTextLen-1;
671
while (EndPtr > CurPtr) and (EndPtr^ in [#10, #13, ' ']) do dec (EndPtr);
673
LineEndPtr := EndPtr;
674
//limit LineEndPtr to first \n
676
while (true) do begin
677
if HelpPtr > LineEndPtr - 1 then break;
678
if (HelpPtr[0] in [#10, #13])
680
LineEndPtr := HelpPtr-1;
681
while (LineEndPtr > CurPtr) and (LineEndPtr^ in [#10, #13, ' ']) do dec (LineEndPtr);
512
while (EndPtr^ in [#10, #13]) do inc(EndPtr);
514
SetLength(Result.GdbDescription, CurPtr - @Result.GdbDescription[1]);
517
StartIdx := pos('type = ', Result.GdbDescription);
518
if StartIdx <= 0 then exit;
520
CurPtr := @Result.GdbDescription[StartIdx];
522
EndIdx := pos(LineEnding, Result.GdbDescription); // the first \n, even if not on the first line
523
if EndIdx <= 0 then EndIdx := length(Result.GdbDescription)+1;
524
EndPtr := @Result.GdbDescription[EndIdx-1];
527
// Pointer indicators
688
BaseDeclPtr := CurPtr;
689
DeclPtr := BaseDeclPtr;
690
DeclEndPtr := LineEndPtr;
529
693
while True do begin
531
'^': include(Result.Flags, ptprfPointer);
696
include(Result.Flags, ptprfPointer);
697
inc(Result.PointerCount);
532
699
'&': include(Result.Flags, ptprfParamByRef);
537
704
SkipSpaces(CurPtr); // shouldn'tever happen
705
BaseDeclPtr := CurPtr;
539
if CurPtr > EndPtr then begin
707
if CurPtr > LineEndPtr then begin
540
708
include(Result.Flags, ptprfEmpty);
712
// entite type in brackest (), eg ^(array...)
713
if CurPtr^ = '(' then begin
714
Include(Result.Flags, ptprfDeclarationInBrackets);
716
SkipSpaces(CurPtr); // shouldn'tever happen
717
BaseDeclPtr := CurPtr;
718
DeclPtr := CurPtr; // not possible to capture with one line, as closing bracket may be on other line
719
if DeclEndPtr^ = ')' then dec(DeclEndPtr);
720
if LineEndPtr^ = ')' then dec(LineEndPtr);
721
if EndPtr^ = ')' then dec(EndPtr);
724
SetPCharLen(Result.BaseDeclaration, BaseDeclPtr, DeclEndPtr);
725
SetPCharLen(Result.Declaration, DeclPtr, DeclEndPtr);
545
727
if CurPtr^ = '=' then begin
548
730
SkipSpaces(CurPtr);
552
// un-named enum // type = = (e1, e2, e3)
553
Result.Kind := ptprkEnum;
554
Result.Declaration.Ptr := CurPtr;
555
Result.Declaration.Len := i;
559
// Unexpected, see if we have a keyword
560
Result.Kind := CheckKeyword;
561
if Result.Kind = ptprkSimple then begin
562
Result.Kind := ptprkError;
563
debugln('** WARNING: ptype info format error: ' + ATypeText);
570
if CurPtr^ = '(' then begin
571
// type in brackets, eg ^(array...)
574
SkipSpaces(CurPtr); // shouldn'tever happen
733
// process part before ' = '
576
734
Result.Kind := CheckKeyword;
577
if Result.Kind = ptprkSimple then begin
735
if Result.Kind = ptprkSimple
578
737
// we may have type = NAME = ....
579
738
HelpPtr := CurPtr;
580
while not (HelpPtr^ in [#0..#31, ' ']) do inc(HelpPtr);
739
while (HelpPtr <= LineEndPtr) and not (HelpPtr^ in [#0..#31, ' ']) do inc(HelpPtr);
740
HelpPtr2 := HelpPtr; // HelpPtr2 = after [name]
582
741
SkipSpaces(HelpPtr2);
583
if ((HelpPtr^ = ' ') and ((HelpPtr2)^ = '='))
584
or (HelpPtr^ in [#0, #10, #13])
743
if (HelpPtr2^ = '=') or // TYPE WITH = (EQUAL)
744
((HelpPtr^ in [#0, #10, #13]) or (HelpPtr > LineEndPtr))
586
746
// Type without space, use as name
587
Result.Name.Ptr := DeclPtr; //CurPtr;
588
Result.Name.Len := HelpPtr - DeclPtr; // CurPtr;
589
while DeclPtr^ in ['&', '^'] do inc(DeclPtr);
590
Result.BaseName.Ptr := DeclPtr; //CurPtr;
591
Result.BaseName.Len := HelpPtr - DeclPtr; // CurPtr;
592
if (HelpPtr^ in [#0, #10, #13]) then exit;
594
// now there must be a keyword or set
595
CurPtr := HelpPtr2 + 1;
596
// Todo: in this case the declaration doe not include the pointer, if any => maybe add flag?
747
SetPCharLen(Result.Name, DeclPtr, HelpPtr-1);
748
SetPCharLen(Result.BaseName, BaseDeclPtr, HelpPtr-1);
750
if (HelpPtr^ in [#0, #10, #13]) or (HelpPtr > LineEndPtr) then exit;
752
CurPtr := HelpPtr2 + 1; // after ' = '
597
753
SkipSpaces(CurPtr);
754
BaseDeclPtr := CurPtr; // Declaration after ' = '
598
755
DeclPtr := CurPtr;
601
Result.Kind := ptprkEnum;
602
Result.Declaration.Ptr := CurPtr;
603
Result.Declaration.Len := i;
607
Result.Kind := CheckKeyword;
608
if Result.Kind = ptprkSimple then begin
609
Result.Kind := ptprkError;
610
debugln('** WARNING: ptype info format error: ' + ATypeText);
615
758
// Type is a declaration with spaces
616
while EndPtr^ = ' ' do dec(EndPtr);
617
Result.Declaration.Ptr := CurPtr;
618
Result.Declaration.Len := EndPtr - CurPtr + 1;
759
// (base)declaration is already set
769
Result.Kind := ptprkEnum;
770
SetPCharLen(Result.BaseDeclaration, CurPtr, CurPtr+i-1);
771
SetPCharLen(Result.Declaration, CurPtr, CurPtr+i-1);
775
Result.Kind := CheckKeyword;
776
if Result.Kind = ptprkSimple then begin
777
Result.Kind := ptprkError;
778
debugln('** WARNING: ptype info format error: ' + ATypeText);
624
782
// now we should be AT a keyword, we may have a name set already // Enum are handled already too
625
while EndPtr^ = ' ' do dec(EndPtr);
783
while LineEndPtr^ = ' ' do dec(LineEndPtr);
626
784
case Result.Kind of
627
785
ptprkClass: begin
628
786
HelpPtr := CurPtr + 5;
629
787
SkipSpaces(HelpPtr);
630
788
if HelpPtr^ in [#10, #13] then include(Result.Flags, ptprfNoStructure);
631
Result.Declaration.Ptr := DeclPtr;
632
Result.Declaration.Len := EndPtr - DeclPtr + 1;
789
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
634
791
ptprkRecord: begin
635
792
HelpPtr := CurPtr + 6;
636
793
SkipSpaces(HelpPtr);
637
Result.Declaration.Ptr := DeclPtr;
638
794
if HelpPtr^ in ['{'] then begin
639
795
include(Result.Flags, ptprfNoStructure);
640
Result.Declaration.Len := CurPtr + 6 - DeclPtr;
796
SetPCharLen(Result.Declaration, DeclPtr, CurPtr + 5);
643
Result.Declaration.Len := EndPtr - DeclPtr + 1;
799
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
646
802
if CurPtr^ <> '<' then begin;
647
Result.Declaration.Ptr := DeclPtr;
648
Result.Declaration.Len := EndPtr - DeclPtr + 1;
803
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
804
//CurPtr := Result.BaseDeclaration.Ptr + 3;
805
CurPtr := CurPtr + 6;
807
if (CurPtr^ = '=') then begin // has enum, no name,
808
CurPtr := CurPtr + 1;
811
SetPCharLen(Result.SubName, CurPtr, LineEndPtr);
812
while (CurPtr^ in ['^', '&']) and (CurPtr < LineEndPtr) do inc(CurPtr); // should not happen
813
SetPCharLen(Result.BaseSubName, CurPtr, LineEndPtr);
814
Result.SubKind := ptprkSimple;
817
Result.Declaration.Ptr := nil;
818
Result.Declaration.Len := 0;
819
Result.BaseDeclaration.Ptr := nil;
820
Result.BaseDeclaration.Len := 0;
651
823
ptprkArray: begin
652
Result.Declaration.Ptr := DeclPtr;
653
Result.Declaration.Len := EndPtr - DeclPtr + 1;
824
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
825
SetPCharLen(Result.BaseDeclaration, BaseDeclPtr, LineEndPtr);
826
CurPtr := CurPtr + 5;
828
include(Result.Flags, ptprfNoBounds);
829
include(Result.Flags, ptprfDynArray);
830
if CurPtr^ = '[' then begin
833
while (HelpPtr^ in ['-', '0'..'9']) and (HelpPtr < LineEndPtr - 3) do inc (HelpPtr);
834
if (HelpPtr > CurPtr) and (HelpPtr^ = '.') and ((HelpPtr+1)^ = '.') then begin
835
HelpPtr2 := HelpPtr + 2;
836
while (HelpPtr2^ in ['-', '0'..'9']) and (HelpPtr2 < LineEndPtr - 1) do inc (HelpPtr2);
837
if (HelpPtr2 > HelpPtr) and (HelpPtr2^ = ']') then begin
838
exclude(Result.Flags, ptprfNoBounds);
839
Result.BoundLow.Ptr := CurPtr;
840
Result.BoundLow.Len := HelpPtr - CurPtr;
841
Result.BoundHigh.Ptr := HelpPtr + 2;
842
Result.BoundHigh.Len := HelpPtr2 - (HelpPtr + 2);
843
if (HelpPtr2 - CurPtr <> 5) or (strlcomp(Result.BoundLow.Ptr, PChar('0..-1'), 5) <> 0) then
844
exclude(Result.Flags, ptprfDynArray);
845
CurPtr := HelpPtr2 + 1;
851
if (CurPtr^ in ['o', 'O']) and ((CurPtr+1)^ in ['f', 'F']) then begin
852
CurPtr := CurPtr + 2;
855
SubRes := ParseTypeFromGdb(CurPtr, EndPtr - CurPtr + 1);
856
if SubRes.Kind = ptprkArray then begin
857
Result.SubName := SubRes.SubName;
858
Result.BaseSubName := SubRes.BaseSubName;
859
Result.SubFlags := SubRes.SubFlags;
860
Result.SubKind := SubRes.SubKind;
861
Result.NestArrayCount := SubRes.NestArrayCount + 1;
862
Result.NestArray := SubRes.NestArray;
863
if length(Result.NestArray) < Result.NestArrayCount
864
then SetLength(Result.NestArray, Result.NestArrayCount + 3);
865
Result.NestArray[SubRes.NestArrayCount].Flags := SubRes.Flags;
866
Result.NestArray[SubRes.NestArrayCount].PointerCount := SubRes.PointerCount;
867
Result.NestArray[SubRes.NestArrayCount].BoundLow := SubRes.BoundLow;
868
Result.NestArray[SubRes.NestArrayCount].BoundHigh := SubRes.BoundHigh;
870
Result.SubName := SubRes.Name;
871
Result.BaseSubName := SubRes.BaseName;
872
Result.SubFlags := SubRes.Flags;
873
Result.SubKind := SubRes.Kind;
877
//SetPCharLen(Result.SubName, CurPtr, LineEndPtr);
878
//while (CurPtr^ in ['^', '&']) and (CurPtr < LineEndPtr) do inc(CurPtr);
879
//SetPCharLen(Result.BaseSubName, CurPtr, LineEndPtr);
655
882
ptprkProcedure, ptprkFunction: begin
656
Result.Declaration.Ptr := DeclPtr;
657
Result.Declaration.Len := EndPtr - DeclPtr + 1;
883
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
887
DebugLn(DBGMI_TYPE_INFO, ['ParseTypeFromGdb: Flags=', dbgs(Result.Flags), ' Kind=', dbgs(Result.Kind), ' Name="', PCLenToString(Result.Name),'"' ]);
891
function ParseTypeFromGdb(const ATypeText: string): TGDBPTypeResult;
895
i := pos('type = ', ATypeText);
897
then Result := ParseTypeFromGdb(PChar(ATypeText), length(ATypeText))
898
else Result := ParseTypeFromGdb((@ATypeText[i])+7, length(ATypeText)-6-i);
899
Result.GdbDescription := ATypeText;
902
function dbgs(AFlag: TGDBPTypeResultFlag): string;
904
writestr(Result, AFlag);
907
function dbgs(AFlags: TGDBPTypeResultFlags): string;
909
i: TGDBPTypeResultFlag;
912
for i := low(TGDBPTypeResultFlags) to high(TGDBPTypeResultFlags) do
913
if i in AFlags then begin
914
if Result <> '' then Result := Result + ', ';
915
Result := Result + dbgs(i);
917
if Result <> '' then Result := '[' + Result + ']';
920
function dbgs(AKind: TGDBPTypeResultKind): string;
922
writestr(Result, AKind);
925
function dbgs(AReqType: TGDBCommandRequestType): string;
927
WriteStr(Result, AReqType);
930
function dbgs(AReq: TGDBPTypeRequest): string;
932
Result := 'Req="'+AReq.Request+'" type='+dbgs(AReq.ReqType)
933
+' HasNext='+dbgs(AReq.Next <> nil)
937
{ TGDBExpressionPartCommaList }
939
function TGDBExpressionPartCommaList.GetTextFixed(AStringFixed: Boolean): String;
944
if PartCount = 0 then
946
Result := Parts[0].GetTextFixed(AStringFixed);
947
for i := 1 to PartCount - 1 do
948
Result := Result + ',' + Parts[i].GetTextFixed(AStringFixed);
951
{ TGDBExpressionPartArrayIdx }
953
function TGDBExpressionPartArrayIdx.GetArrayPTypeIsDeRef: boolean;
955
Result := (FPTypeReq.Result.Kind <> ptprkArray);
958
function TGDBExpressionPartArrayIdx.GetArrayPTypeIsPointer: boolean;
960
if FArrayPTypeNestIdx < 0 then begin
963
else Result := ptprfPointer in FPTypeReq.Result.Flags;
966
Result := ptprfPointer in ArrayPTypeResult.NestArray[FArrayPTypeNestIdx].Flags;
970
function TGDBExpressionPartArrayIdx.GetArrayPTypeResult: TGDBPTypeResult;
972
Result := FPTypeReq.Result;
973
if (Result.Kind <> ptprkArray) then
974
Result := FPTypeDeRefReq.Result;
977
procedure TGDBExpressionPartArrayIdx.Init;
980
FPTypeReq.Result.Kind := ptprkNotEvaluated;
981
FPTypeDeRefReq.Result.Kind := ptprkNotEvaluated;
982
FPTypeIndexReq.Result.Kind := ptprkNotEvaluated;
984
FArrayPTypeNestidx := -1;
985
FArrayPTypePointerIdx := 0;
988
procedure TGDBExpressionPartArrayIdx.InitReq(var AReqPtr: PGDBPTypeRequest; AReqText: String);
990
InitReq(AReqPtr, FPTypeReq, AReqText, gcrtPType);
993
procedure TGDBExpressionPartArrayIdx.InitDeRefReq(var AReqPtr: PGDBPTypeRequest;
996
InitReq(AReqPtr, FPTypeDeRefReq, AReqText, gcrtPType);
999
procedure TGDBExpressionPartArrayIdx.InitIndexReq(var AReqPtr: PGDBPTypeRequest);
1001
InitReq(AReqPtr, FPTypeIndexReq,
1002
GdbCmdEvaluate + Quote(GetPlainText), gcrtEvalExpr);
1005
function TGDBExpressionPartArrayIdx.GetTextFixed(AStringFixed: Boolean): String;
1007
if AStringFixed then begin
1008
if FExpressionPart = nil
1009
then Result := PCLenPartToString(FText, 1, FText.Len-2)
1010
else Result := FExpressionPart.Text;
1011
Result := FText.Ptr^ + Result + '-1' + (FText.Ptr + FText.Len-1)^;
1014
Result := inherited GetTextFixed(AStringFixed);
1017
function TGDBExpressionPartArrayIdx.CreateExpressionForSubIndex(AIndex: Integer): TGDBExpressionPartArrayIdx;
1019
Result := TGDBExpressionPartArrayIdx.Create
1020
(FText.Ptr^ + Parts[AIndex].GetText + (FText.Ptr + FText.Len-1)^);
1023
{ TGDBExpressionPartList }
1025
function TGDBExpressionPartList.AddList(APartList: TGDBExpressionPartList): Integer;
1030
if APartList.PartCount = 0 then exit;
1031
Result := FList.add(APartList.Parts[0]);
1032
for i := 1 to APartList.PartCount - 1 do
1033
FList.add(APartList.Parts[i]);
1036
{ TGDBExpressionPartArray }
1038
function TGDBExpressionPartArray.GetIndexParts(Index: Integer): TGDBExpressionPartArrayIdx;
1042
Result := TGDBExpressionPartArrayIdx(Parts[Index+1]);
1044
if Result.IsCommaSeparated then begin
1046
For j := 0 to Result.PartCount-1 do
1047
Insert(Index + 1 + j, Result.CreateExpressionForSubIndex(j));
1049
Result := TGDBExpressionPartArrayIdx(Parts[Index+1]);
1053
function TGDBExpressionPartArray.GetTextFixed(AStringFixed: Boolean): String;
1055
Result := GetTextToIdx(IndexCount-1, AStringFixed);
1058
function TGDBExpressionPartArray.GetTextToIdx(AIdx: Integer; AStrFixed: Boolean = False): String;
1060
function GetPointerCast(AnIdxPart: TGDBExpressionPartArrayIdx; out PointerCnt: Integer): String;
1062
PTRes: TGDBPTypeResult;
1067
if not AnIdxPart.ArrayPTypeIsPointer then exit;
1068
PTRes := AnIdxPart.ArrayPTypeResult;
1069
if PTRes.SubName.Len = 0 then exit;
1071
i := PTRes.NestArrayCount - 1;
1072
if i >= 0 then begin
1073
while (i >= 0) and (ptprfPointer in PTRes.NestArray[i].Flags) do dec(i);
1074
if i >= 0 then exit; // cant cast, if contains static array
1075
PointerCnt := PTRes.NestArrayCount+1;
1076
Result := StringOfChar('^', PointerCnt) + PCLenToString(PTRes.SubName);
1080
PointerCnt := PTRes.PointerCount;
1081
// If PTRes is the result of an extra de-ref in the ptype, then we need to add that pointer back
1082
if AnIdxPart.ArrayPTypeIsDeRef then
1084
Result := StringOfChar('^', PointerCnt) + PCLenToString(PTRes.SubName);
1088
i, j, PCastCnt: Integer;
1089
IdxPart: TGDBExpressionPartArrayIdx;
1090
PTResult: TGDBPTypeResult;
1094
Result := Parts[0].Text;
1097
if AIdx < 0 then exit;
1099
for i := 0 to AIdx do begin
1100
IdxPart := TGDBExpressionPartArrayIdx(Parts[i + 1]);
1101
PTResult := IdxPart.ArrayPTypeResult;
1102
if PCastCnt > 0 then dec(PCastCnt);
1104
if not (PTResult.Kind = ptprkArray)
1106
// maybe pointer with index access
1107
if AStrFixed and (i = IndexCount - 1)
1108
then Result := Result + IdxPart.TextStrFixed
1109
else Result := Result + IdxPart.Text;
1113
if ((PTResult.NestArrayCount > 0) and (IdxPart.ArrayPTypeNestIdx <> PTResult.NestArrayCount-1)) or
1114
(IdxPart.ArrayPTypePointerIdx > 0)
1116
// nested array / no named type known
1117
if (PCastCnt = 0) and IdxPart.ArrayPTypeIsPointer
1118
then Result := Result + '^';
1119
Result := Result + IdxPart.Text;
1124
NeedTCast := FNeedTypeCast and (i = IndexCount-1);
1126
if IdxPart.ArrayPTypeIsPointer
1130
if IdxPart.VarParam then
1131
s := GetPointerCast(IdxPart, j);
1132
if s <> '' // IdxPart.VarParam and (PTResult.SubName.Len > 0) // var param can only be set for the un-inxed variable
1134
// fpc 2.4.4 Var-param dynarray
1135
// var param are marked with a "&" in fpc 2.4. They are a semi automatic pointer.
1136
// Any such var param, that points to an internal pointer type (e.g dyn array) must be typecasted, to trigger the semi automatic pointer of the var-param
1137
// For single dyn array: ^Foo(var)[1]
1138
// For nested dyn array: ^^Foo(var)[1][2] // the ^ in front of the index must be skipped, as the dyn array was casted into a pointer
1139
Result := s + '(' + Result + ')';
1144
if (PCastCnt = 0) then
1145
Result := Result + '^';
1148
Result := Result + IdxPart.Text;
1150
if NeedTCast and (PTResult.SubName.Len > 0)
1152
Result := PCLenToString(PTResult.SubName) + '(' + Result + ')';
1158
function TGDBExpressionPartArray.IndexCount: Integer;
1160
Result := PartCount - 1;
1163
constructor TGDBExpressionPartArray.Create(ALeadExpresion: TGDBExpressionPart);
1166
FNeedTypeCast := False;
1167
Add(ALeadExpresion);
1170
function TGDBExpressionPartArray.AddIndex(APart: TGDBExpressionPartArrayIdx): Integer;
1172
Result := Add(APart);
1175
function TGDBExpressionPartArray.NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean;
1176
function IsNumber(s: String): Boolean;
1180
while (i >= 1) and (s[i] in ['0'..'9']) do dec(i);
1185
IdxPart, IdxPart2: TGDBExpressionPartArrayIdx;
1186
PTReq, PTDeRefReq: TGDBPTypeRequest;
1187
ArrRes: TGDBPTypeResult;
1188
ResultList: TGDBMINameValueList;
1193
for i := 1 to PartCount - 1 do
1194
if Parts[i].NeedValidation(AReqPtr) then
1197
if Parts[0].NeedValidation(AReqPtr) // Array-Variable
1202
if Result then exit;
1205
while i < IndexCount do begin
1206
// IdxPart is the NEXT index. We evaluate the expression BEFORE IdxPart
1207
IdxPart := IndexPart[i];
1208
PTReq := IdxPart.PTypeReq;
1210
if PTReq.Result.Kind = ptprkError
1212
// "Parts[i]" Check if the part before IndexParts[i] needs typecastfixing
1213
if (pos('address 0x0', PTReq.Error) > 0) and Parts[i].MayNeedTypeCastFix
1215
Result := Parts[i].NeedValidation(AReqPtr);
1216
PTReq.Result.Kind := ptprkNotEvaluated; // Reset the request
1217
IdxPart.PTypeReq := PTReq;
1220
exit; // If Result = False; // no way to find more info
1221
// Todo, simply to next entry, and check for "pointer math on incomplete type"
1224
if PTReq.Result.Kind = ptprkNotEvaluated
1226
IdxPart.VarParam := False;
1227
// InitReq sets: PTReq.Result.Kind = ptprkError;
1228
IdxPart.InitReq(AReqPtr, GdbCmdPType + GetTextToIdx(i-1));
1233
if (not IdxPart.VarParam) and (ptprfParamByRef in PTReq.Result.Flags)
1235
// FPC 2.2.4 encoded "var param" in a special way, and we need an extra deref)
1236
IdxPart.VarParam := True;
1237
IdxPart.InitReq(AReqPtr, GdbCmdPType + GetTextToIdx(i-1) + '^');
1242
(* With Dwarf gdb may return "type = ^TFoo" for an array
1243
And the for the derefferenced expr "type = array of TFoo"
1245
PTDeRefReq := IdxPart.PTypeDeRefReq;
1246
if (PTReq.Result.Kind <> ptprkArray) and
1247
(ptprfPointer in PTReq.Result.Flags) and
1248
(PTDeRefReq.Result.Kind = ptprkNotEvaluated)
1251
then IdxPart.InitDeRefReq(AReqPtr, GdbCmdPType + GetTextToIdx(i-1) + '^^')
1252
else IdxPart.InitDeRefReq(AReqPtr, GdbCmdPType + GetTextToIdx(i-1) + '^');
1257
// we may have nested array (dyn array only):
1259
// - array ... oaf array
1260
// A combination of both is not expected
1262
ArrRes := IdxPart.ArrayPTypeResult;
1263
if (ArrRes.Kind = ptprkArray) and (ArrRes.NestArrayCount > 0) then begin
1264
j := ArrRes.NestArrayCount;
1265
while j > 0 do begin
1268
if i >= IndexCount then break;
1269
IdxPart2 := IndexPart[i];
1270
IdxPart2.PTypeReq := IdxPart.PTypeReq;
1271
IdxPart2.PTypeDeRefReq := IdxPart.PTypeDeRefReq;
1272
IdxPart2.ArrayPTypeNestIdx := j;
1277
if (ArrRes.Kind = ptprkArray) and (ArrRes.PointerCount > 1) then begin
1278
j := ArrRes.PointerCount - 1;
1279
while j > 0 do begin
1282
if i >= IndexCount then break;
1283
IdxPart2 := IndexPart[i];
1284
IdxPart2.PTypeReq := IdxPart.PTypeReq;
1285
IdxPart2.PTypeDeRefReq := IdxPart.PTypeDeRefReq;
1286
IdxPart2.ArrayPTypePointerIdx := j;
1293
if IndexCount=0 then exit;
1295
// check if we may access a char in a string
1296
IdxPart := IndexPart[IndexCount-1];
1297
PTReq := IdxPart.PTypeReq;
1298
if (PTReq.Result.Kind = ptprkSimple) and
1299
not(IdxPart.PTypeDeRefReq.Result.Kind = ptprkArray)
1301
s := LowerCase(PCLenToString(PTReq.Result.BaseName));
1302
if (ptprfPointer in PTReq.Result.Flags) and
1303
( ( s = 'char') or (s = 'character') or (s = 'wchar') or (s = 'widechar') )
1305
if IsNumber(IdxPart.GetPlainText)
1307
FMaybeString := True;
1310
PTReq := IdxPart.PTypeIndexReq;
1311
if PTReq.Result.Kind = ptprkNotEvaluated
1313
IdxPart.InitIndexReq(AReqPtr);
1318
if (PTReq.Result.Kind = ptprkSimple)
1320
ResultList := TGDBMINameValueList.Create(PTReq.Result.GdbDescription);
1321
FMaybeString := IsNumber(ResultList.Values['value']);
1330
function TGDBExpressionPartArray.MayNeedStringFix: Boolean;
1332
Result := FMaybeString;
1334
Result := inherited MayNeedStringFix;
1337
{ TGDBExpressionPartCastCall }
1339
procedure TGDBExpressionPartCastCall.Init;
1342
FPTypeReq.Result.Kind := ptprkNotEvaluated;
1345
function TGDBExpressionPartCastCall.GetTextFixed(AStringFixed: Boolean): String;
1347
Result := inherited GetTextFixed(AStringFixed);
1348
if FTypeCastFixFlag = tcfFixNeeded then
1349
Result := '^'+Result;
1352
function TGDBExpressionPartCastCall.NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean;
1354
Result := inherited NeedValidation(AReqPtr);
1356
if IsFunction or (FTypeCastFixFlag <> tcfEvalNeeded) then
1359
if FPTypeReq.Result.Kind = ptprkNotEvaluated then begin
1360
InitReq(AReqPtr, FPTypeReq, GdbCmdPType + Parts[0].GetText , gcrtPType);
1365
if (FPTypeReq.Result.Kind = ptprkError) or (FPTypeReq.Error <> '') then begin
1366
FTypeCastFixFlag := tcfNoFixNeeded;
1370
if FPTypeReq.Result.Kind = ptprkClass then begin
1371
FTypeCastFixFlag := tcfFixNeeded;
1372
FIsTypeCast := True;
1376
if FPTypeReq.Result.Kind = ptprkRecord then begin // Includes pointer to array
1377
FTypeCastFixFlag := tcfNoFixNeeded; // TODO: Maybe it is needed?
1378
FIsTypeCast := True;
1382
if FPTypeReq.Result.Kind in [ptprkProcedure, ptprkFunction] then begin
1383
FTypeCastFixFlag := tcfNoFixNeeded;
1384
FIsFunction := True;
1388
FTypeCastFixFlag := tcfNoFixNeeded;
1391
constructor TGDBExpressionPartCastCall.Create(ALeadExpresion: TGDBExpressionPart);
1397
Add(ALeadExpresion);
1398
FIsFunction := False;
1399
FIsTypeCast := False;
1400
FTypeCastFixFlag := tcfUnknown;
1401
s := ALeadExpresion.GetText;
1404
while (i <= l) and (s[i] in [' ', #9]) do inc(i);
1406
while (i <= l) and (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) do inc(i);
1407
while (i <= l) and (s[i] in [' ', #9]) do inc(i);
1408
FIsFunction := i < l; // Contains chars that are not allowed in type identifiers (like foo.bar())
1413
function TGDBExpressionPartCastCall.AddBrackets(APart: TGDBExpressionPart): Integer;
1415
Result := Add(APart);
1418
function TGDBExpressionPartCastCall.MayNeedTypeCastFix: Boolean;
1420
Result := inherited MayNeedTypeCastFix;
1424
if not(FTypeCastFixFlag in [tcfUnknown, tcfEvalNeeded]) then
1428
FTypeCastFixFlag := tcfEvalNeeded;
1431
{ TGDBExpressionPartBracketed }
1433
function TGDBExpressionPartBracketed.GetTextFixed(AStringFixed: Boolean): String;
1435
if FExpressionPart = nil
1436
then Result := inherited GetTextFixed(AStringFixed)
1437
else Result := FText.Ptr^ + FExpressionPart.GetTextFixed(AStringFixed) + (FText.Ptr + FText.Len-1)^;
1440
function TGDBExpressionPartBracketed.GetPlainText: String;
1442
if FExpressionPart = nil
1443
then Result := PCLenPartToString(FText, 1, FText.Len-2)
1444
else Result := FExpressionPart.Text;
1447
constructor TGDBExpressionPartBracketed.Create(AText: PChar; ATextLen: Integer);
1449
CreateSimple(AText, ATextLen);
1450
FExpressionPart := ParseExpression(FText.Ptr+1, FText.Len-2);
1453
{ TGDBExpressionPart }
1455
function TGDBExpressionPart.GetTextFixed(AStringFixed: Boolean): String;
1457
Result := PCLenToString(FText);
1460
function TGDBExpressionPart.GetText: String;
1462
Result := GetTextFixed(False);
1465
function TGDBExpressionPart.ParseExpression(AText: PChar; ATextLen: Integer): TGDBExpressionPart;
1467
// include "." (dots). currently there is no need to break expressions like "foo.bar"
1468
// Include "^" (deref)
1469
// do NOT include "@", it is applied after []() resolution
1470
WordChar = ['a'..'z', 'A'..'Z', '0'..'9', '_', '#', '$', '%', '&', '^', '.'];
1472
CurPtr, EndPtr: PChar;
1475
procedure SkipSpaces;
1477
while (CurPtr < EndPtr) and (CurPtr^ in [#9, ' ']) do inc(CurPtr);
1480
procedure ScanToWordEnd;
1485
// include "." (dots). currently there is no need to break expressions like "foo.bar"
1486
// Include "^" (deref)
1487
while (CurPtr < EndPtr) do begin
1489
if (c in WordChar) then begin
1492
else if (c in [' ', #9]) then begin
1493
f := ((CurPtr-1)^ in ['.', '^']);
1495
if not(f or ((CurPtr < EndPtr) and (CurPtr^ in ['.', '^'])) ) then
1503
procedure ScanToWordStart;
1505
while (CurPtr < EndPtr) and not( (CurPtr^ in WordChar) or (CurPtr^ = ',') )
1509
function ScanToCallCastEnd: Boolean;
1514
while (CurPtr < EndPtr) do begin
1530
function ScanToIndexEnd: Boolean;
1535
while (CurPtr < EndPtr) do begin
1551
procedure AddExpPart(aList: TGDBExpressionPartList);
1553
NewList: TGDBExpressionPartList;
1555
if aList.PartCount = 0 then exit;
1556
if (aList.PartCount = 1) and (Result = nil) then begin
1557
Result := aList.Parts[0];
1563
then Result := TGDBExpressionPartList.Create
1565
if not (Result is TGDBExpressionPartList)
1567
NewList := TGDBExpressionPartList.Create;
1568
NewList.Add(Result);
1572
TGDBExpressionPartList(Result).AddList(aList);
1576
function MoveListToCopy(aList: TGDBExpressionPartList): TGDBExpressionPart;
1578
if aList.PartCount = 1
1580
Result := aList.Parts[0];
1583
Result := TGDBExpressionPartList.Create;
1584
TGDBExpressionPartList(Result).AddList(aList);
1590
CurList: TGDBExpressionPartList;
1591
CurArray: TGDBExpressionPartArray;
1592
CurCast: TGDBExpressionPartCastCall;
1593
FCommaList: TGDBExpressionPartCommaList;
1594
CurWord: TGDBExpression;
1599
EndPtr := AText + ATextLen;
1601
while (CurPtr < EndPtr) and not(CurPtr^ in ['[', '(', ',']) do inc(CurPtr);
1602
if CurPtr = EndPtr then exit; // no fixup needed
1605
CurList:= TGDBExpressionPartList.Create;
1607
while CurPtr < EndPtr do begin
1611
if FCommaList = nil then
1612
FCommaList := TGDBExpressionPartCommaList.Create;
1613
AddExpPart(CurList);
1614
FCommaList.Add(Result);
1619
if CurPtr^ in WordChar
1621
CurPartPtr := CurPtr;
1623
CurWord := TGDBExpression.CreateSimple(CurPartPtr, CurPtr - CurPartPtr);
1624
CurList.Add(CurWord);
1625
if (CurPtr^ in WordChar) or CurWord.IsNamedOperator then // 2 words => named operator (and/or)
1626
AddExpPart(CurList);
1629
if (CurList.PartCount > 0) and (CurPtr^ = '[')
1631
CurArray := TGDBExpressionPartArray.Create(MoveListToCopy(CurList));
1632
CurList.Add(CurArray);
1633
while (CurPtr^ = '[') do begin
1634
CurPartPtr := CurPtr;
1635
if not ScanToIndexEnd then break; // broken expression, do not attempt to do anything
1636
CurArray.AddIndex(TGDBExpressionPartArrayIdx.Create(CurPartPtr, CurPtr - CurPartPtr));
1639
if (CurPtr < EndPtr ) and (CurPtr^ in ['.', '^', '(']) then
1640
CurArray.NeedTypeCast := True;
1643
if (CurList.PartCount > 0) and (CurPtr^ = '(')
1645
CurCast := TGDBExpressionPartCastCall.Create(MoveListToCopy(CurList));
1646
CurList.Add(CurCast);
1647
CurPartPtr := CurPtr;
1648
if not ScanToCallCastEnd then break; // broken expression, do not attempt to do anything
1649
CurCast.AddBrackets(TGDBExpressionPartBracketed.Create(CurPartPtr, CurPtr - CurPartPtr));
1652
CurPartPtr := CurPtr;
1654
CurList.Add(TGDBExpression.CreateSimple(CurPartPtr, CurPtr - CurPartPtr));
1655
AddExpPart(CurList);
1660
AddExpPart(CurList);
1663
if FCommaList <> nil then begin
1664
if Result <> nil then
1665
FCommaList.Add(Result);
1666
Result := FCommaList;
1670
if CurPtr < EndPtr then debugln(['Scan aborted: ', PCLenToString(FText)]);
1671
if CurPtr < EndPtr then FreeAndNil(Result);
1674
procedure TGDBExpressionPart.Init;
1679
procedure TGDBExpressionPart.InitReq(var AReqPtr: PGDBPTypeRequest;
1680
var AReqVar: TGDBPTypeRequest; AReqText: String; AType: TGDBCommandRequestType);
1682
AReqVar.Request := AReqText;
1683
AReqVar.Error := '';
1684
AReqVar.ReqType := AType;
1685
AReqVar.Next := AReqPtr;
1686
AReqVar.Result.Kind := ptprkError;
1687
AReqPtr := @AReqVar;
1690
function TGDBExpressionPart.NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean;
1695
for i := 0 to PartCount - 1 do
1696
if Parts[i].NeedValidation(AReqPtr) then
1700
function TGDBExpressionPart.MayNeedStringFix: Boolean;
1705
for i := 0 to PartCount - 1 do
1706
if Parts[i].MayNeedStringFix then
1710
function TGDBExpressionPart.MayNeedTypeCastFix: Boolean;
1715
for i := 0 to PartCount - 1 do
1716
if Parts[i].MayNeedTypeCastFix then
1720
constructor TGDBExpressionPart.Create;
1725
function TGDBExpressionPart.IsNamedOperator: Boolean;
1729
s := LowerCase(Trim(GetText));
1730
Result := (s = 'not') or (s = 'or') or (s = 'xor') or (s = 'and');
1733
function TGDBExpressionPart.GetTextStrFixed: String;
1735
Result := GetTextFixed(True);
1738
function TGDBExpressionPart.GetParts(Index: Integer): TGDBExpressionPart;
1743
function TGDBExpressionPart.PartCount: Integer;
1748
{ TGDBExpressionPartListBase }
1750
function TGDBExpressionPartListBase.GetParts(Index: Integer): TGDBExpressionPart;
1752
Result := TGDBExpressionPart(FList[Index]);
1755
function TGDBExpressionPartListBase.GetTextFixed(AStringFixed: Boolean): String;
1760
for i := 0 to PartCount - 1 do
1761
Result := Result + Parts[i].GetTextFixed(AStringFixed);
1764
constructor TGDBExpressionPartListBase.Create;
1767
FList := TFPList.Create;
1770
destructor TGDBExpressionPartListBase.Destroy;
1777
procedure TGDBExpressionPartListBase.Clear;
1779
while FList.Count > 0 do begin
1780
TGDBExpressionPart(Flist[0]).Free;
1785
procedure TGDBExpressionPartListBase.ClearShared;
1790
function TGDBExpressionPartListBase.Add(APart: TGDBExpressionPart): Integer;
1792
Result := FList.Add(APart);
1795
procedure TGDBExpressionPartListBase.Insert(AIndex: Integer; APart: TGDBExpressionPart);
1797
FList.Insert(AIndex, APart);
1800
procedure TGDBExpressionPartListBase.Delete(AIndex: Integer);
1802
FList.Delete(AIndex);
1805
function TGDBExpressionPartListBase.PartCount: Integer;
1807
Result := FList.Count;
1812
function TGDBExpression.GetTextFixed(AStringFixed: Boolean): String;
1814
if FExpressionPart = nil
1815
then Result := inherited GetTextFixed(AStringFixed)
1816
else Result := FExpressionPart.GetTextFixed(AStringFixed);
1819
function TGDBExpression.GetParts(Index: Integer): TGDBExpressionPart;
1822
if FExpressionPart = nil then exit;
1823
if FExpressionPart is TGDBExpressionPartList
1824
then Result := FExpressionPart.Parts[Index]
1825
else Result := FExpressionPart;
1828
constructor TGDBExpression.CreateSimple(AText: PChar; ATextLen: Integer);
1832
FExpressionPart := nil;
1834
FText.Len := ATextLen;
1837
constructor TGDBExpression.Create(AText: PChar; ATextLen: Integer);
1839
CreateSimple(AText, ATextLen);
1840
FExpressionPart := ParseExpression(FText.Ptr, FText.Len);
1843
constructor TGDBExpression.Create(ATextStr: String);
1845
FTextStr := ATextStr;
1846
Create(PChar(FTextStr), length(FTextStr));
1849
destructor TGDBExpression.Destroy;
1851
FreeAndNil(FExpressionPart);
1855
function TGDBExpression.PartCount: Integer;
1858
if FExpressionPart = nil then exit;
1859
if FExpressionPart is TGDBExpressionPartList
1860
then Result := FExpressionPart.PartCount
1864
function TGDBExpression.IsCommaSeparated: Boolean;
1866
Result := (FExpressionPart <> nil) and (FExpressionPart is TGDBExpressionPartCommaList);
1869
{ TGDBPTypeRequestCache }
1871
function TGDBPTypeRequestCache.GetRequest(Index: Integer): TGDBPTypeRequest;
1873
Result := TGDBPTypeRequestCacheEntry(FList[Index]).FRequest;
1876
constructor TGDBPTypeRequestCache.Create;
1878
FList := TFPList.Create;
1881
destructor TGDBPTypeRequestCache.Destroy;
1888
procedure TGDBPTypeRequestCache.Clear;
1890
while FList.Count > 0 do begin
1891
TGDBPTypeRequestCacheEntry(FList[0]).Free;
1896
function TGDBPTypeRequestCache.IndexOf(AThreadId, AStackFrame: Integer;
1897
ARequest: TGDBPTypeRequest): Integer;
1899
e: TGDBPTypeRequestCacheEntry;
1901
Result := FList.Count - 1;
1902
while Result >= 0 do begin
1903
e := TGDBPTypeRequestCacheEntry(FList[Result]);
1904
if (e.ThreadId = AThreadId) and (e.StackFrame = AStackFrame) and
1905
(e.Request.Request =ARequest.Request) and
1906
(e.Request.ReqType =ARequest.ReqType)
1913
procedure TGDBPTypeRequestCache.Add(AThreadId, AStackFrame: Integer;
1914
ARequest: TGDBPTypeRequest);
1916
e: TGDBPTypeRequestCacheEntry;
1918
e := TGDBPTypeRequestCacheEntry.Create;
1919
e.FThreadId := AThreadId;
1920
e.FStackFrame := AStackFrame;
1921
e.FRequest := ARequest;
1922
e.FRequest.Next := nil;
876
2273
Name := GetPart([' '], [' '], S);
877
DBGType := TGDBType.Create(skSimple, GetPart([' : '], [';'], S));
2274
S2 := GetPart([' : '], [';'], S);
2275
if (lowercase(copy(S2, 1, 7)) = 'record ') then begin
2277
while (n < Lines.Count - 2) and (i > 0) do
2281
if S = '' then Continue;
2282
if pos(': record ', S) > 0 then inc(i);
2283
if pos(' end;', S) > 0 then dec(i);
2284
S2 := S2 + ' ' + Trim(S);
2287
DBGType := TGDBType.Create(skSimple, S2);
880
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags));
2289
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags, FTypeName));
885
procedure ProcessClassNamePType;
888
FTypeName := ClearAmpersand(PCLenToString(FWhatIsExprReq.Result.Name));
889
FInternalTypeName := FTypeName;
891
if (FExtraReq.Error <> '') or (FExtraReq.Result.Kind = ptprkError)
892
or (FExtraReq.Result.BaseName.Len = 0)
895
debugln('Failed "PTYPE" request for class type name');
899
if (not (ptprfPointer in FExtraReq.Result.Flags))
901
// Actual Class, Not a pointer
912
procedure ProcessClassNameWhatIs;
914
// Dwarf, Classes are always pointer
915
FTypeName := ClearAmpersand(PCLenToString(FWhatIsExprReq.Result.Name));
916
FInternalTypeName := FTypeName;
918
if (FExtraReq.Error <> '') or (FExtraReq.Result.Kind = ptprkError)
919
or (FExtraReq.Result.BaseName.Len = 0)
922
debugln('Failed "WHATIS" request for class type name');
926
// dwarf, expect always pointer, but may have " = class"
927
if (not (ptprfPointer in FExtraReq.Result.Flags))
928
or (FExtraReq.Result.Kind = ptprkClass)
930
// Actual Class, Not a pointer
941
procedure ProcessClassWhatIs;
943
if (FWhatIsExprReq.Error <> '') or (FWhatIsExprReq.Result.Kind = ptprkError)
944
or (FWhatIsExprReq.Result.BaseName.Len = 0)
946
// failed to get a classname => assume class
947
debugln('Failed "WHATIS" request for class expression');
948
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
949
FInternalTypeName := FTypeName;
2294
procedure ProcessClassPointer;
2296
FProcessState := gtpsClassPointer;
2297
if not RequireRequests([gptrWhatisExpr]) then
2301
SetTypNameFromReq(gptrWhatisExpr);
2306
procedure ProcessClassAncestor;
2310
FProcessState := gtpsClassAncestor;
2312
If FTypeInfoAncestor = nil then begin
2313
FTypeInfoAncestor := TGDBType.CreateForExpression(FAncestor,
2314
FCreationFlags*[gtcfClassIsPointer, gtcfFullTypeInfo, gtcfSkipTypeName] + [gtcfExprIsType]
2316
AddSubType(FTypeInfoAncestor);
2318
if not FTypeInfoAncestor.IsFinished then
2322
if FTypeInfoAncestor.FFields <> nil then
2323
for i := 0 to FTypeInfoAncestor.FFields.Count - 1 do
2324
FFields.Add(FTypeInfoAncestor.FFields[i]);
2328
procedure FinishProcessClass;
2330
FProcessState := gtpsFinishProcessClass;
2331
if (gtcfFullTypeInfo in FCreationFlags) and not (gtcfExprIsType in FCreationFlags) then
2332
if not RequireRequests([gptrWhatisExpr]) then
2335
// Handle Error in ptype^ as normal class
2336
// May need a whatis, if aliased names are needed "type TFooAlias = type TFoo"
2337
SetTypNameFromReq(gptrWhatisExpr, True);
2339
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
2340
then ProcessClassAncestor
2341
else Result := True; // ====> DONE
2344
procedure ProcessClass;
2346
t: TGDBTypeProcessRequest;
2347
ResultList: TGDBMINameValueList;
2351
FProcessState := gtpsClass;
2353
if (gtcfExprIsType in FCreationFlags) then begin
2354
SetTypNameFromReq(gptrPTypeExpr, True);
2356
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
2357
then ProcessClassAncestor
2358
else Result := True; // ====> DONE
956
if (ptprfParamByRef in FWhatIsExprReq.Result.Flags) then
957
include(FAttributes, saRefParam);
959
if (ptprfPointer in FWhatIsExprReq.Result.Flags)
960
and (FWhatIsExprReq.Result.Kind = ptprkSimple) // Typename alias, must be simple
2362
if saRefParam in FAttributes
2363
then t := gptrPTypeExprDeDeRef // &Class (var param; dwarf)
2364
else t := gptrPTypeExprDeRef; // Class
2366
if not RequireRequests([gptrPTypeExpr, t])
2370
then debugln('Failed "ptype expr^[^]" request for class expression');
2372
if (not IsReqError(t)) and (ptprfPointer in FReqResults[t].Result.Flags)
964
FTypeName := ClearAmpersand(PCLenToString(FWhatIsExprReq.Result.Name));
965
FInternalTypeName := FTypeName;
2374
ProcessClassPointer;
971
if FClassIsPointer then begin
972
// Dwarf, Classes are always pointer // need Whatis <type>
973
AddTypeReq(FExtraReq, 'whatis ' + PCLenToString(FWhatIsExprReq.Result.BaseName));
974
FProcessState := gtpsClassNameWhatIs;
975
// ====> state = ClassNameWhats
978
// Stabs // need PType <type>
979
AddTypeReq(FExtraReq, 'ptype ' + PCLenToString(FWhatIsExprReq.Result.BaseName));
980
FProcessState := gtpsClassNamePType;
981
// ====> state = ClassNamePType
2379
FTypeDeclaration := PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName);
2381
if (gtcfAutoCastClass in FCreationFlags) then begin
2382
if not RequireRequests([gptrInstanceClassName]) then
2384
if not IsReqError(gptrInstanceClassName) then begin
2385
ResultList := TGDBMINameValueList.Create(FReqResults[gptrInstanceClassName].Result.GdbDescription);
2386
s := ParseGDBString(ResultList.Values['value']);
2391
if i <= length(s)-1 then begin
2392
FAutoTypeCastName := copy(s, 2, i);
2393
RequireRequests([gptrPtypeCustomAutoCast], FAutoTypeCastName);
2394
FProcessState := gtpsClassAutoCast;
2397
// continue without type cast
2405
procedure ProcessClassAutoCast;
2409
if IsReqError(gptrPtypeCustomAutoCast) or
2410
(not(FReqResults[gptrPtypeCustomAutoCast].Result.Kind = ptprkClass)) or
2411
(LowerCase(FAutoTypeCastName) = LowerCase(PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName))) // don't typecast to itself
2413
FinishProcessClass; // normal class finish
2417
s := FAutoTypeCastName + '(' + FExpression + ')';
2418
if not RequireRequests([gptrPtypeCustomAutoCast2], s)
2421
if FHasAutoTypeCastFix
2424
if IsReqError(gptrPtypeCustomAutoCast2) and (not FHasAutoTypeCastFix)
2427
FHasAutoTypeCastFix := True;
2428
exclude(FProccesReuestsMade, gptrPtypeCustomAutoCast2);
2429
RequireRequests([gptrPtypeCustomAutoCast2], s);
2433
if IsReqError(gptrPtypeCustomAutoCast2) or
2434
not(FReqResults[gptrPtypeCustomAutoCast2].Result.Kind = ptprkClass)
2436
FinishProcessClass; // normal class finish
2441
FReqResults[gptrPTypeExpr] := FReqResults[gptrPtypeCustomAutoCast2];
2442
exclude(FProccesReuestsMade, gptrWhatisExpr);
984
2445
{%endregion * Class * }
2447
{%region * Array * }
2448
procedure ProcessArray;
2450
PTypeResult: TGDBPTypeResult;
2452
FProcessState := gtpsArray;
2454
PTypeResult := FReqResults[gptrPTypeExpr].Result;
2455
// In DWARF, some Dynamic Array, are pointer to there base type
2456
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
2458
if not RequireRequests([gptrPTypeExprDeRef])
2460
if (not IsReqError(gptrPTypeExprDeRef)) then
2461
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result;
2462
// This implies it is an internal pointer
2463
if (ptprfDynArray in PTypeResult.Flags)
2464
then include(FAttributes, saInternalPointer);
2467
if (PTypeResult.Flags * [ptprfDynArray, ptprfPointer] = [ptprfDynArray, ptprfPointer])
2468
then include(FAttributes, saInternalPointer);
2470
if (saInternalPointer in FAttributes) then begin
2471
if not RequireRequests([gptrPTypeExprDeRef])
2475
if (saInternalPointer in FAttributes) and (not IsReqError(gptrPTypeExprDeRef)) then
2476
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result
2478
PTypeResult := FReqResults[gptrPTypeExpr].Result;
2480
if ptprfPointer in PTypeResult.Flags then begin
2481
ProcessSimplePointer;
2486
if (ptprfDynArray in PTypeResult.Flags)
2487
then include(FAttributes, saDynArray)
2488
else include(FAttributes, saArray);
2490
if not(gtcfSkipTypeName in FCreationFlags) then begin
2491
if not RequireRequests([gptrWhatisExpr])
2493
SetTypNameFromReq(gptrWhatisExpr, True);
2496
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
2500
{%endregion * Array * }
986
2502
{%region * Simple * }
987
2503
procedure ProcessSimplePointer;
2505
FProcessState := gtpsSimplePointer;
2506
// there may be multiply levels of pointer, get the name of this pointer
2507
if not RequireRequests([gptrPTypeExpr, gptrWhatisExpr])
989
2510
FKind := skPointer;
990
if (FWhatIsExprReq.Error = '') and (FWhatIsExprReq.Result.Kind = ptprkSimple) then begin
2511
if not IsReqError(gptrWhatisExpr) and (FReqResults[gptrWhatisExpr].Result.Kind = ptprkSimple)
991
2513
// Whatis result is ok
992
if (ptprfParamByRef in FWhatIsExprReq.Result.Flags) then
2514
if (ptprfParamByRef in FReqResults[gptrWhatisExpr].Result.Flags) then
993
2515
include(FAttributes, saRefParam);
994
FTypeName := ClearAmpersand(PCLenToString(FWhatIsExprReq.Result.Name));
2516
SetTypNameFromReq(gptrWhatisExpr);
997
2519
// Whatis result failed
998
FTypeName := ClearAmpersand((PCLenToString(FPTypeExprReq.Result.Name)));
2520
SetTypNameFromReq(gptrPTypeExpr);
1000
FInternalTypeName := FTypeName;
1001
2522
Result := True;
1004
2525
{%endregion * Simple * }
1006
procedure ProcessInitialPType;
1008
if FPTypeExprReq.Error <> '' then begin
2527
{%region * EvaluateExpression * }
2528
function GetParsedFromResult(AGdbDesc, AField: String): String;
2530
ResultList: TGDBMINameValueList;
2532
ResultList := TGDBMINameValueList.Create(AGdbDesc);
2533
Result := ResultList.Values[AField];
2534
//FTextValue := DeleteEscapeChars(FTextValue);
2537
procedure ParseFromResult(AGdbDesc, AField: String);
2539
FExprEvaluatedAsText := GetParsedFromResult(AGdbDesc, AField);
2540
FHasExprEvaluatedAsText := True;
2542
procedure ParseFromResultForStrFixed(AGdbDesc, AField: String);
2544
FStringExprEvaluatedAsText := GetParsedFromResult(AGdbDesc, AField);
2545
FHasStringExprEvaluatedAsText := True;
2548
procedure EvaluateExpressionDynArrayGetData;
2553
FProcessState := gtpsEvalExprDynArrayGetData;
2555
if (FLen <= 0) or (FArrayIndexValueLimit <= 0) then begin
2560
if (Length(FArrayIndexValues) > 0) then begin
2561
FExprEvaluatedAsText := '';
2562
for i := 0 to Length(FArrayIndexValues) - 1 do begin
2563
s := FArrayIndexValues[i].ExprEvaluatedAsText;
2564
if (pos(' ', s) > 0) or (pos(',', s) > 0) then
2567
FExprEvaluatedAsText := FExprEvaluatedAsText + ', ';
2568
FExprEvaluatedAsText := FExprEvaluatedAsText + s;
2570
if FArrayIndexValueLimit < FLen then
2571
FExprEvaluatedAsText := FExprEvaluatedAsText + ', ...';
2577
if (FExprEvaluatedAsText <> '') and
2578
(FExprEvaluatedAsText[1] = '{') // gdb returned array data
2581
((Length(FExprEvaluatedAsText) > 1) and (FExprEvaluatedAsText[2] <> '}') )
2589
m := Min(FArrayIndexValueLimit, FLen);
2590
SetLength(FArrayIndexValues, m);
2591
for i := 0 to m-1 do begin
2592
FArrayIndexValues[i] := TGDBType.CreateForExpression(FExpression+'['+IntToStr(i)+']',
2593
FCreationFlags + [gtcfExprEvaluate]);
2595
then FArrayIndexValues[i].FArrayIndexValueLimit := FArrayIndexValueLimit - 2
2596
else FArrayIndexValues[i].FArrayIndexValueLimit := FArrayIndexValueLimit - 3;
2597
AddSubType(FArrayIndexValues[i]);
2601
procedure EvaluateExpressionDynArray;
2603
FProcessState := gtpsEvalExprDynArray;
2604
if FExprEvaluateFormat <> wdfDefault then begin;
2614
if not RequireRequests([gptrPtypeCustomEval], '^^longint('+FExpression+')[-1]') then exit;
2615
if not IsReqError(gptrPtypeCustomEval, False) then begin
2617
FBoundHigh := StrToIntDef(GetParsedFromResult(FReqResults[gptrPtypeCustomEval].Result.GdbDescription, 'value'), -1);
2618
FLen := FBoundHigh + 1;
2621
if (saInternalPointer in FAttributes) then begin
2622
if not RequireRequests([gptrEvalExprDeRef]) then exit;
2623
if not IsReqError(gptrEvalExprDeRef, False) then begin
2624
ParseFromResult(FReqResults[gptrEvalExprDeRef].Result.GdbDescription, 'value');
2625
EvaluateExpressionDynArrayGetData;
2630
if (saRefParam in FAttributes) then begin
2631
if not RequireRequests([gptrEvalExprCast]) then exit;
2632
if not IsReqError(gptrEvalExprCast, False) then begin
2633
ParseFromResult(FReqResults[gptrEvalExprCast].Result.GdbDescription, 'value');
2634
EvaluateExpressionDynArrayGetData;
2639
if not RequireRequests([gptrEvalExpr]) then exit;
2640
if not IsReqError(gptrEvalExpr, False) then begin
2641
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'value');
2642
EvaluateExpressionDynArrayGetData;
2646
if FLen > 0 then begin
2647
EvaluateExpressionDynArrayGetData;
2651
// TODO: set Validity = error
2652
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'msg');
2656
procedure EvaluateExpressionArray;
2658
PTypeResult: TGDBPTypeResult;
2660
FProcessState := gtpsEvalExprArray;
2661
if FExprEvaluateFormat <> wdfDefault then begin;
2666
PTypeResult := FReqResults[gptrPTypeExpr].Result;
2667
FBoundLow := PCLenToInt(PTypeResult.BoundLow);
2668
FBoundHigh := PCLenToInt(PTypeResult.BoundHigh);
2669
FLen := PCLenToInt(PTypeResult.BoundHigh) - PCLenToInt(PTypeResult.BoundLow) + 1;
2672
if (saInternalPointer in FAttributes) then begin
2673
if not RequireRequests([gptrEvalExprDeRef]) then exit;
2674
if not IsReqError(gptrEvalExprDeRef, False) then begin
2675
ParseFromResult(FReqResults[gptrEvalExprDeRef].Result.GdbDescription, 'value');
2681
if (saRefParam in FAttributes) then begin
2682
if not RequireRequests([gptrEvalExprCast]) then exit;
2683
if not IsReqError(gptrEvalExprCast, False) then begin
2684
ParseFromResult(FReqResults[gptrEvalExprCast].Result.GdbDescription, 'value');
2690
if not RequireRequests([gptrEvalExpr]) then exit;
2691
if not IsReqError(gptrEvalExpr, False) then begin
2692
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'value');
2697
// TODO: set Validity = error
2698
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'msg');
2702
procedure EvaluateExpression;
2704
FProcessState := gtpsEvalExpr;
2706
if not(gtcfExprEvaluate in FCreationFlags) then begin
2711
if saDynArray in FAttributes then begin
2712
EvaluateExpressionDynArray;
2715
if saArray in FAttributes then begin
2716
EvaluateExpressionArray;
2720
if FExprEvaluateFormat <> wdfDefault then begin;
2725
// TODO: stringFixed need to know about:
2728
if (saInternalPointer in FAttributes) then begin
2729
if not RequireRequests([gptrEvalExprDeRef]) then exit;
2730
if not IsReqError(gptrEvalExprDeRef, False) then begin
2731
ParseFromResult(FReqResults[gptrEvalExprDeRef].Result.GdbDescription, 'value');
2733
if (gtcfExprEvalStrFixed in FCreationFlags) and
2734
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
2736
if not RequireRequests([gptrEvalExprDeRef2], FParsedExpression.TextStrFixed) then exit;
2737
ParseFromResultForStrFixed(FReqResults[gptrEvalExprDeRef2].Result.GdbDescription, 'value');
2745
if (saRefParam in FAttributes) then begin
2746
if not RequireRequests([gptrEvalExprCast]) then exit;
2747
if not IsReqError(gptrEvalExprCast, False) then begin
2748
ParseFromResult(FReqResults[gptrEvalExprCast].Result.GdbDescription, 'value');
2750
if (gtcfExprEvalStrFixed in FCreationFlags) and
2751
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
2753
if not RequireRequests([gptrEvalExprCast2], FParsedExpression.TextStrFixed) then exit;
2754
ParseFromResultForStrFixed(FReqResults[gptrEvalExprCast2].Result.GdbDescription, 'value');
2762
if not RequireRequests([gptrEvalExpr]) then exit;
2763
if not IsReqError(gptrEvalExpr, False) then begin
2764
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'value');
2766
if (gtcfExprEvalStrFixed in FCreationFlags) and
2767
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
2769
if not RequireRequests([gptrEvalExpr2], FParsedExpression.TextStrFixed) then exit;
2770
ParseFromResultForStrFixed(FReqResults[gptrEvalExpr2].Result.GdbDescription, 'value');
2777
// TODO: set Validity = error
2778
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'msg');
2781
{%endregion * EvaluateExpression * }
2783
procedure ProcessInitialSimple;
2786
PTypeResult: TGDBPTypeResult;
2788
FProcessState := gtpsInitialSimple;
2790
// TODO: ptype may be known by FParsedExpression
2791
if not RequireRequests([gptrPTypeExpr]) //+wi)
2794
if IsReqError(gptrPTypeExpr) then begin
2795
//Cannot access memory at address 0x0
2796
if (pos('address 0x0', FReqResults[gptrPTypeExpr].Error) > 0) and
2797
FParsedExpression.MayNeedTypeCastFix
2799
exclude(FProccesReuestsMade, gptrPTypeExpr);
1009
2804
FEvalError := True;
2807
PTypeResult := FReqResults[gptrPTypeExpr].Result;
1013
if (ptprfParamByRef in FPTypeExprReq.Result.Flags) then
2809
if (ptprfParamByRef in PTypeResult.Flags) then
1014
2810
include(FAttributes, saRefParam);
1017
if (ptprfPointer in FPTypeExprReq.Result.Flags)
1018
and ( (FPTypeExprReq.Result.Kind in
1019
[ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
1020
or (FClassIsPointer and (FPTypeExprReq.Result.Kind in
1021
[ptprkProcedure, ptprkFunction]) )
2812
// In DWARF, some Dynamic Array, are pointer to there base type
2813
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
2815
if not RequireRequests([gptrPTypeExprDeRef])
2817
if (not IsReqError(gptrPTypeExprDeRef)) and
2818
(FReqResults[gptrPTypeExprDeRef].Result.Kind = ptprkArray)
2825
case PTypeResult.Kind of
2843
if (ptprfPointer in PTypeResult.Flags)
2844
and ( (PTypeResult.Kind in [ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
2845
or ( (gtcfClassIsPointer in FCreationFlags) and
2846
(PTypeResult.Kind in [ptprkProcedure, ptprkFunction]) )
1024
// there may be multiply levels of pointer, get the name of this pointer
1025
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1026
FProcessState := gtpsSimplePointer;
1027
// ====> state = SimplePointer
2849
ProcessSimplePointer;
1031
if (ptprfParamByRef in FPTypeExprReq.Result.Flags)
1032
and not (FPTypeExprReq.Result.Kind in [ptprkError, ptprkClass])
2853
if (ptprfParamByRef in PTypeResult.Flags)
2854
and not (PTypeResult.Kind in [ptprkError])
1034
2856
// could be a pointer // need ptype of whatis
1035
if FProcessState = gtpsInitialPType then begin
1036
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1037
FProcessState := gtpsInitialPType2;
1038
// ====> state = gtpsInitialPType2
1041
else if (FProcessState = gtpsInitialPType2) and (FWhatIsExprReq.Result.BaseName.Len > 0)
2857
if not RequireRequests([gptrWhatisExpr])
2860
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0)
1043
AddTypeReq(FExtraReq, 'ptype ' + PCLenToString(FWhatIsExprReq.Result.BaseName));
1044
FProcessState := gtpsInitialPType3;
1045
// ====> state = gtpsInitialPType2
1048
else // must be gtpsInitialPType3
1049
if (FExtraReq.Error = '') and (ptprfPointer in FExtraReq.Result.Flags) then begin
1052
FTypeName := ClearAmpersand(PCLenToString(FWhatIsExprReq.Result.Name));
1053
FInternalTypeName := FTypeName;
2862
if not RequireRequests([gptrPTypeOfWhatis])
2865
if (not IsReqError(gptrPTypeOfWhatis, False))
2866
and (ptprfPointer in FReqResults[gptrPTypeOfWhatis].Result.Flags) then begin
2869
SetTypNameFromReq(gptrWhatisExpr);
1060
case FPTypeExprReq.Result.Kind of
2877
case PTypeResult.Kind of
1061
2878
ptprkError: begin
1062
2879
// could be empty pointer @ArgProcedure
1063
2880
Result := True; // nothing to be done, keep simple type, no name
1065
2882
ptprkSimple: begin
1066
2883
// may only need whatis, if current name isn't usable?
1067
if FProcessState = gtpsInitialPType then begin
1068
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1069
FProcessState := gtpsInitialPType2;
1070
// ====> state = gtpsInitialPType2
1073
if (FWhatIsExprReq.Result.BaseName.Len > 0) then
1074
FTypeName := PCLenToString(FWhatIsExprReq.Result.BaseName)
1076
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1077
FInternalTypeName := FTypeName; // There may be an alias?
2884
if not RequireRequests([gptrWhatisExpr])
2887
SetTypNameFromReq(gptrWhatisExpr, True);
1083
2892
ptprkClass: begin
1084
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1085
FProcessState := gtpsClassWhatIs; // ====> state = ClassWhatis
2893
Assert(False, 'GDBTypeInfo Class: Should be handled before');
1087
2896
ptprkRecord: begin
1088
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1089
FInternalTypeName := FTypeName; // There may be an alias?
2897
SetTypNameFromReq(gptrWhatisExpr, True);
1091
2899
Result := True;
1094
2902
ptprkEnum: begin
1095
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1096
FInternalTypeName := FTypeName; //s There may be an alias?
2903
SetTypNameFromReq(gptrWhatisExpr, True);
2904
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
1098
2906
Result := True;
1101
2909
ptprkSet: begin
1102
if FProcessState = gtpsInitialPType then begin
1103
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1104
FProcessState := gtpsInitialPType2;
1105
// ====> state = gtpsInitialPType2
1108
if (FWhatIsExprReq.Result.BaseName.Len > 0) then
1109
FTypeName := PCLenToString(FWhatIsExprReq.Result.BaseName)
1111
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1112
FInternalTypeName := FTypeName;
2910
if not RequireRequests([gptrWhatisExpr])
2913
SetTypNameFromReq(gptrWhatisExpr, True);
2914
// TODO: resolve enum-name (set of SomeEnum) if mode-full ?
2915
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
2916
i := pos('set of = ', FTypeDeclaration);
2917
if i > 0 then delete(FTypeDeclaration, i+7, 3);
1118
2922
ptprkArray: begin
1119
if FProcessState = gtpsInitialPType then begin
1120
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1121
FProcessState := gtpsInitialPType2;
1122
// ====> state = gtpsInitialPType2
1126
if (FWhatIsExprReq.Result.BaseName.Len > 0) then
1127
FTypeName := PCLenToString(FWhatIsExprReq.Result.BaseName)
1129
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1130
FInternalTypeName := FTypeName;
2923
Assert(False, 'GDBTypeInfo Array: Should be handled before');
1135
2926
ptprkProcedure: begin
1136
2927
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
1137
if FClassIsPointer // Dwarf
1138
and (ptprfPointer in FPTypeExprReq.Result.Flags)
2928
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
2929
and (ptprfPointer in PTypeResult.Flags)
1140
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1141
FProcessState := gtpsSimplePointer;
1142
// ====> state = SimplePointer
1145
if FProcessState = gtpsInitialPType then begin
1146
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1147
FProcessState := gtpsInitialPType2;
1148
// ====> state = gtpsInitialPType2
1151
if (FWhatIsExprReq.Result.BaseName.Len > 0) then
1152
FTypeName := PCLenToString(FWhatIsExprReq.Result.BaseName)
1154
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1155
if FTypeName = '' then FTypeName := 'procedure';
1156
FInternalTypeName := FTypeName;
2931
ProcessSimplePointer;
2935
if not RequireRequests([gptrWhatisExpr])
2938
SetTypNameFromReq(gptrWhatisExpr, True, 'procedure');
1162
2943
ptprkFunction: begin
1163
2944
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
1164
if FClassIsPointer // Dwarf
1165
and (ptprfPointer in FPTypeExprReq.Result.Flags)
2945
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
2946
and (ptprfPointer in PTypeResult.Flags)
1167
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1168
FProcessState := gtpsSimplePointer;
1169
// ====> state = SimplePointer
1172
if FProcessState = gtpsInitialPType then begin
1173
AddTypeReq(FWhatIsExprReq, 'whatis ' + FExpression);
1174
FProcessState := gtpsInitialPType2;
1175
// ====> state = gtpsInitialPType2
1178
if (FWhatIsExprReq.Result.BaseName.Len > 0) then
1179
FTypeName := PCLenToString(FWhatIsExprReq.Result.BaseName)
1181
FTypeName := PCLenToString(FPTypeExprReq.Result.BaseName);
1182
if FTypeName = '' then FTypeName := 'function';
1183
FInternalTypeName := FTypeName;
1192
procedure InitializeProcessing;
1194
AddTypeReq(FPTypeExprReq, 'ptype ' + FExpression);
1195
FProcessState := gtpsInitialPType;
2948
ProcessSimplePointer;
2952
if not RequireRequests([gptrWhatisExpr])
2955
SetTypNameFromReq(gptrWhatisExpr, True, 'function');
2963
procedure ProcessInitial;
2965
FProcessState := gtpsInitial;
2966
if FExpression = '' then begin;
2967
ProcessInitialSimple;
2971
if FParsedExpression = nil
2972
then FParsedExpression := TGDBExpression.Create(FExpression);
2973
// Does not set FLastEvalRequest
2974
if FParsedExpression.NeedValidation(FEvalRequest)
2977
FExpression := FParsedExpression.Text;
2979
ProcessInitialSimple;
2982
procedure MergeSubProcessRequests;
2986
SubType := FFirstProcessingSubType;
2987
while SubType <> nil do begin
2988
if (FEvalRequest = nil)
2989
then FEvalRequest := SubType.FEvalRequest
2990
else if FLastEvalRequest <> nil
2991
then FLastEvalRequest^.Next := SubType.FEvalRequest
2994
FLastEvalRequest := FEvalRequest;
2995
while (FLastEvalRequest^.Next <> nil) do
2996
FLastEvalRequest := FLastEvalRequest^.Next;
2997
FLastEvalRequest^.Next := SubType.FEvalRequest;
2999
FLastEvalRequest := SubType.FLastEvalRequest;
3000
SubType := SubType.FNextProcessingSubType;
3004
function ProcessSubProcessRequests: Boolean;
3006
SubType, PrevSubType: TGDBType;
3009
SubType := FFirstProcessingSubType;
3010
while SubType <> nil do begin
3011
DebugLnEnter(DBGMI_TYPE_INFO, ['>>Enter Sub-Request']);
3012
if SubType.ProcessExpression then begin
3013
if PrevSubType = nil
3014
then FFirstProcessingSubType := SubType.FNextProcessingSubType
3015
else PrevSubType.FNextProcessingSubType := SubType.FNextProcessingSubType;
3018
PrevSubType := SubType;
3019
SubType := SubType.FNextProcessingSubType;
3020
DebugLnExit(DBGMI_TYPE_INFO, ['>>Leave Sub-Request']);
3023
Result := FFirstProcessingSubType = nil;
1199
3027
OldProcessState: TGDBTypeProcessState;
3028
OldReqMade: TGDBTypeProcessRequests;
1201
3031
Result := False;
1202
3032
FEvalRequest := nil;
3033
FLastEvalRequest := nil;
3035
WriteStr(s, FProcessState); // TODO dbgs
3036
DebugLnEnter(DBGMI_TYPE_INFO, ['>>Enter: TGDBType.ProcessExpression: state = ', s, ' Expression="', FExpression, '"']);
3040
if FFirstProcessingSubType <> nil then begin
3041
if not ProcessSubProcessRequests then begin
3042
MergeSubProcessRequests;
1204
3047
OldProcessState := FProcessState;
3048
OldReqMade := FProccesReuestsMade;
1206
3050
case FProcessState of
1207
gtpsInitial: InitializeProcessing;
1210
gtpsInitialPType3: ProcessInitialPType;
1211
gtpsSimplePointer: ProcessSimplePointer;
1212
gtpsClassWhatIs: ProcessClassWhatIs;
1213
gtpsClassNameWhatIs: ProcessClassNameWhatIs;
1214
gtpsClassNamePType: ProcessClassNamePType;
3051
gtpsInitial: ProcessInitial;
3052
gtpsInitialSimple: ProcessInitialSimple;
3053
gtpsSimplePointer: ProcessSimplePointer;
3054
gtpsClass: ProcessClass;
3055
gtpsClassAutoCast: ProcessClassAutoCast;
3056
gtpsClassPointer: ProcessClassPointer;
3057
gtpsFinishProcessClass: FinishProcessClass;
3058
gtpsClassAncestor: ProcessClassAncestor;
3059
gtpsArray: ProcessArray;
3060
gtpsEvalExpr: EvaluateExpression;
3061
gtpsEvalExprArray: EvaluateExpressionArray;
3062
gtpsEvalExprDynArray: EvaluateExpressionDynArray;
3063
gtpsEvalExprDynArrayGetData: EvaluateExpressionDynArrayGetData;
1217
3066
FreeAndNil(Lines);
1218
if (FProcessState = OldProcessState) and (not Result) and (FEvalRequest = nil)
3067
if Result and not(FEvalStarted)
3070
FEvalStarted := True;
3075
then FProcessState := gtpsFinished;
3077
if FFirstProcessingSubType <> nil then
3078
MergeSubProcessRequests
3080
if (FProcessState = OldProcessState) and (FProccesReuestsMade = OldReqMade)
3081
and (not Result) and (FEvalRequest = nil)
1220
3083
debugln('ERROR: detected state loop in ProcessExpression');
1221
3084
Result := True;
3087
WriteStr(s, FProcessState);
3088
DebugLnExit(DBGMI_TYPE_INFO, ['<<Exit: TGDBType.ProcessExpression: state = ', s, ' Result=', dbgs(Result),
3089
' Kind=', dbgs(Kind), ' Attr=', dbgs(Attributes), ' Typename="', TypeName, '" InternTpName="', FInternalTypeName,'" TypeDeclaration="', TypeDeclaration, '"']);
added
removed
debugger/gdbtypeinfo.pp
