paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-27 18:33:50 +02:00
Code Issues Packages Projects Releases Wiki Activity
369017a0c5
lazarus/debugger/gdbtypeinfo.pp

2725 lines
80 KiB
ObjectPascal
Raw Blame History

{ $Id$ }
{ ----------------------------------------------
GDBTypeInfo.pp - Debugger helper class
----------------------------------------------
@created(Wed Mar 29th WET 2003)
@lastmod($Date$)
@author(Marc Weustink <marc@@dommelstein.net>)
This unit contains a helper class for decoding PType output.
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
unit GDBTypeInfo;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Debugger, LclProc, DebugUtils, GDBMIMiscClasses;
(*
ptype = {
family = "class" | "record" | "enum" | "set" | "procedure" | "function" | "simple" | "pointer"
[ ancestor = "...", ]
[ private = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
[ protected = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
[ public = "[" ( "{" name = "...", type = ptype "}" )* "},"]
[ published = "[" ( "{" name = "...", type = ptype "}" )* "}," ]
[ members = "[" ( "..." )* "]," | "[" ( "{" name = "...", type = "..." "}" )* "]," ]
[ args = "[" ( "..." )* "]," ]
[ result = "..." ]
[ name = "..." ]
[ type = "..." ]
For example results, comparision between similar types, different GDB versions
or stabs vs dwarf, see the folder "test/gdb responses/"
*)
type
TGDBPTypeResultFlag =
(ptprfParamByRef,
ptprfPointer,
ptprfNoStructure, // for Class or Record: no full class declaration, type ends after class keyword; DWARF "whatis TFoo"
// includes "record {...}"
ptprfDynArray,
ptprfNoBounds, // no bounds for array found
ptprfEmpty,
ptprfDeclarationInBrackets // e.g ^(array ...) / "&^()" is/are not included in BaseDeclaration
);
TGDBPTypeResultFlags = set of TGDBPTypeResultFlag;
TGDBPTypeResultKind =
(ptprkNotEvaluated, ptprkError, ptprkSimple, ptprkClass, ptprkRecord,
ptprkEnum, ptprkSet, ptprkArray, ptprkProcedure, ptprkFunction);
TGDBPTypeResult = record
GdbDescription: string;
Flags: TGDBPTypeResultFlags;
Kind: TGDBPTypeResultKind;
Name, BaseName: TPCharWithLen; // BaseName is without ^&
BoundLow, BoundHigh: TPCharWithLen;
Declaration, BaseDeclaration: TPCharWithLen; // BaseDeclaration only for Array and Set types, see note on ptprfDeclarationInBrackets
PointerCount: Integer;
// type of array entry, or set-enum
SubName, BaseSubName: TPCharWithLen;
SubFlags: TGDBPTypeResultFlags;
SubKind: TGDBPTypeResultKind;
// multi-dim array
NestArrayCount: Integer;
NestArray: array of record // reverse order, last entry is first nest level
Flags: TGDBPTypeResultFlags;
BoundLow, BoundHigh: TPCharWithLen;
PointerCount: Integer;
end;
end;
TGDBCommandRequestType = (gcrtPType, gcrtEvalExpr);
PGDBPTypeRequest = ^TGDBPTypeRequest;
TGDBPTypeRequest = record
Request: string;
ReqType: TGDBCommandRequestType;
Result: TGDBPTypeResult;
Error: string;
Next: PGDBPTypeRequest;
end;
(* List: "ACount", "+", "1"
Array: "Item[1][2]"
Cast/Call: "Foo(Bar)"
*)
{ TGDBExpressionPart }
TGDBExpressionPart = class
protected
FText: TPCharWithLen;
function GetParts(Index: Integer): TGDBExpressionPart; virtual;
function GetTextFixed(AStringFixed: Boolean): String; virtual;
function GetText: String;
function GetTextStrFixed: String;
function ParseExpression(AText: PChar; ATextLen: Integer): TGDBExpressionPart;
procedure Init; virtual;
public
function NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean; virtual;
function MayNeedStringFix: Boolean; virtual;
public
constructor Create;
function PartCount: Integer; virtual;
property Parts[Index: Integer]: TGDBExpressionPart read GetParts;
property Text: String read GetText;
property TextStrFixed: String read GetTextStrFixed;
end;
{ TGDBExpression }
TGDBExpression = class(TGDBExpressionPart)
private
FTextStr: String;
protected
FExpressionPart: TGDBExpressionPart;
function GetTextFixed(AStringFixed: Boolean): String; override;
function GetParts(Index: Integer): TGDBExpressionPart; override;
public
constructor CreateSimple(AText: PChar; ATextLen: Integer);
constructor Create(AText: PChar; ATextLen: Integer);
constructor Create(ATextStr: String);
destructor Destroy; override;
function PartCount: Integer; override;
end;
{ TGDBExpressionPartBracketed }
TGDBExpressionPartBracketed = class(TGDBExpression)
protected
function GetTextFixed(AStringFixed: Boolean): String; override;
function GetPlainText: String;
public
constructor Create(AText: PChar; ATextLen: Integer);
end;
{ TGDBExpressionPartListBase }
TGDBExpressionPartListBase = class(TGDBExpressionPart)
private
FList: TFPList;
protected
function GetParts(Index: Integer): TGDBExpressionPart; override;
function GetTextFixed(AStringFixed: Boolean): String; override;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure ClearShared;
function Add(APart: TGDBExpressionPart):Integer;
function PartCount: Integer; override;
end;
TGDBExpressionPartList = class(TGDBExpressionPartListBase)
public
function AddList(APartList: TGDBExpressionPartList):Integer;
end;
{ TGDBExpressionPartArrayIdx }
TGDBExpressionPartArrayIdx = class(TGDBExpressionPartBracketed)
private
FArrayPTypeNestIdx: integer;
FArrayPTypePointerIdx: integer;
FPTypeIndexReq: TGDBPTypeRequest;
FVarParam: Boolean;
FPTypeReq: TGDBPTypeRequest;
FPTypeDeRefReq: TGDBPTypeRequest;
function GetArrayPTypeIsDeRef: boolean;
function GetArrayPTypeIsPointer: boolean;
function GetArrayPTypeResult: TGDBPTypeResult;
protected
procedure Init; override;
procedure InitReq(var AReqPtr: PGDBPTypeRequest; AReqText: String);
procedure InitDeRefReq(var AReqPtr: PGDBPTypeRequest; AReqText: String);
procedure InitIndexReq(var AReqPtr: PGDBPTypeRequest);
function GetTextFixed(AStringFixed: Boolean): String; override;
property VarParam: Boolean read FVarParam write FVarParam;
property PTypeReq: TGDBPTypeRequest read FPTypeReq write FPTypeReq;
property PTypeDeRefReq: TGDBPTypeRequest read FPTypeDeRefReq write FPTypeDeRefReq;
property PTypeIndexReq: TGDBPTypeRequest read FPTypeIndexReq write FPTypeIndexReq;
property ArrayPTypeResult: TGDBPTypeResult read GetArrayPTypeResult;
property ArrayPTypeIsDeRef: boolean read GetArrayPTypeIsDeRef;
property ArrayPTypeIsPointer: boolean read GetArrayPTypeIsPointer;
property ArrayPTypeNestIdx: integer read FArrayPTypeNestIdx write FArrayPTypeNestIdx;
property ArrayPTypePointerIdx: integer read FArrayPTypePointerIdx write FArrayPTypePointerIdx;
end;
{ TGDBExpressionPartArray }
TGDBExpressionPartArray = class(TGDBExpressionPartListBase)
private
FNeedTypeCast: Boolean;
FMaybeString: Boolean;
function GetIndexParts(Index: Integer): TGDBExpressionPartArrayIdx;
protected
function GetTextFixed(AStringFixed: Boolean): String; override;
function GetTextToIdx(AIdx: Integer; AStrFixed: Boolean = False): String;
function IndexCount: Integer;
property IndexPart[Index: Integer]: TGDBExpressionPartArrayIdx read GetIndexParts;
public
constructor Create(ALeadExpresion: TGDBExpressionPart);
function AddIndex(APart: TGDBExpressionPartArrayIdx):Integer;
function NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean; override;
function MayNeedStringFix: Boolean; override;
property NeedTypeCast: Boolean read FNeedTypeCast write FNeedTypeCast;
end;
{ TGDBExpressionPartCastCall }
TGDBExpressionPartCastCall = class(TGDBExpressionPartListBase)
private
public
constructor Create(ALeadExpresion: TGDBExpressionPart);
function AddBrackets(APart: TGDBExpressionPart):Integer;
end;
{ TGDBPTypeRequestCacheEntry }
TGDBPTypeRequestCacheEntry = class
protected
FRequest: TGDBPTypeRequest;
FStackFrame: Integer;
FThreadId: Integer;
public
property ThreadId: Integer read FThreadId;
property StackFrame: Integer read FStackFrame;
property Request: TGDBPTypeRequest read FRequest;
end;
TGDBPTypeRequestCache = class
private
FList: TFPList;
function GetRequest(Index: Integer): TGDBPTypeRequest;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function IndexOf(AThreadId, AStackFrame: Integer; ARequest: TGDBPTypeRequest): Integer;
procedure Add(AThreadId, AStackFrame: Integer; ARequest: TGDBPTypeRequest);
property Request[Index: Integer]: TGDBPTypeRequest read GetRequest;
end;
{ TGDBTypes }
TGDBTypes = class(TDBGTypes)
public
constructor CreateFromCSV(AValues: String);
end;
{ TGDBType }
TGDBTypeCreationFlag = (gtcfClassIsPointer,
gtcfFullTypeInfo,
gtcfSkipTypeName,
gtcfExprIsType,
gtcfExprEvaluate,
gtcfExprEvalStrFixed, // Evaluate with string fix, if needed; only if gtcfExprEvaluate is set
gtcfAutoCastClass // Find real class of instance, and use, instead of declared class of variable
);
TGDBTypeCreationFlags = set of TGDBTypeCreationFlag;
TGDBTypeProcessState =
(gtpsInitial, gtpsInitialSimple, gtpsInitFixTypeCast,
gtpsSimplePointer,
gtpsClass, gtpsClassAutoCast, gtpsClassPointer, gtpsClassAncestor,
gtpsArray,
gtpsEvalExpr,
gtpsFinished
);
TGDBTypeProcessRequest =
(gptrPTypeExpr, gptrWhatisExpr, gptrPTypeOfWhatis,
gptrPTypeExprDeRef, gptrPTypeExprDeDeRef, // "Foo^", "Foo^^" for Foo=Object, or &Object
gptrEvalExpr, gptrEvalExprDeRef, gptrEvalExprCast,
gptrEvalExpr2, gptrEvalExprDeRef2, gptrEvalExprCast2, // used by MaybeString
gptrPtypeCustomFixCast, gptrPtypeCustomAutoCast, gptrPtypeCustomAutoCast2,
gptrInstanceClassName
);
TGDBTypeProcessRequests = set of TGDBTypeProcessRequest;
TGDBType = class(TDBGType)
private
FInternalTypeName: string;
private
FExpression, FOrigExpression: string;
FHasStringExprEvaluatedAsText: Boolean;
FCreationFlags: TGDBTypeCreationFlags;
// Value-Eval
FExprEvaluatedAsText: String;
FHasExprEvaluatedAsText: Boolean;
FExprEvaluateFormat: TWatchDisplayFormat;
// Sub-Types (FNext is managed by creator / linked list)
FFirstProcessingSubType, FNextProcessingSubType: TGDBType;
FStringExprEvaluatedAsText: String;
FTypeInfoAncestor: TGDBType;
FTypeInfoArrayExpression: TGDBType;
// Gdb-Requests
FEvalError: boolean;
FEvalRequest, FLastEvalRequest: PGDBPTypeRequest;
FProcessState: TGDBTypeProcessState;
FProccesReuestsMade: TGDBTypeProcessRequests;
FReqResults: Array [TGDBTypeProcessRequest] of TGDBPTypeRequest;
FParsedExpression: TGDBExpression;
FHasTypeCastFix, FHasAutoTypeCastFix: Boolean;
FAutoTypeCastName: String;
procedure AddTypeReq(var AReq :TGDBPTypeRequest; const ACmd: string = '');
procedure AddSubType(ASubType :TGDBType);
function GetIsFinished: Boolean;
function RequireRequests(ARequired: TGDBTypeProcessRequests; ACustomData: String = ''): Boolean;
function IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
protected
procedure Init; override;
public
constructor CreateForExpression(const AnExpression: string;
const AFlags: TGDBTypeCreationFlags;
AFormat: TWatchDisplayFormat = wdfDefault);
destructor Destroy; override;
function ProcessExpression: Boolean;
property EvalRequest: PGDBPTypeRequest read FEvalRequest;
property EvalError: boolean read FEvalError;
property IsFinished: Boolean read GetIsFinished;
property HasExprEvaluatedAsText: Boolean read FHasExprEvaluatedAsText;
property ExprEvaluatedAsText: String read FExprEvaluatedAsText;
// Expression with index fixed by -1 for string access
property HasStringExprEvaluatedAsText: Boolean read FHasStringExprEvaluatedAsText;
property StringExprEvaluatedAsText: String read FStringExprEvaluatedAsText;
public
// InternalTypeName: include ^ for TObject, if needed
property InternalTypeName: string read FInternalTypeName;
end;
function CreatePTypeValueList(AResultValues: String): TStringList;
function ParseTypeFromGdb(const ATypeText: string): TGDBPTypeResult;
function dbgs(AFlag: TGDBPTypeResultFlag): string; overload;
function dbgs(AFlags: TGDBPTypeResultFlags): string; overload;
function dbgs(AKind: TGDBPTypeResultKind): string; overload;
function dbgs(AReqType: TGDBCommandRequestType): string; overload;
function dbgs(AReq: TGDBPTypeRequest): string; overload;
implementation
function CreatePTypeValueList(AResultValues: String): TStringList;
var
S, Line: String;
Lines: TStringList;
procedure DoRecord;
var
n: Integer;
S, Members: String;
begin
Result.Add('family=record');
Members := '';
//concatinate all lines and skip last end
S := '';
for n := 0 to Lines.Count - 2 do
S := S + Lines[n];
while S <> '' do
begin
if Members <> '' then Members := Members + ',';
Members := Members + '{name=' + GetPart([' '], [' '], S);
Members := Members + ',type=' + GetPart([' : '], [';'], S) + '}';
end;
Result.Add('members=[' + Members + ']');
end;
procedure DoEnum;
var
n: Integer;
S: String;
begin
Result.Add('family=enum');
S := GetPart(['('], [], Line);
//concatinate all lines
for n := 0 to Lines.Count - 1 do
S := S + Lines[n];
S := GetPart([], [')'], S);
Result.Add('members=[' + StringReplace(S, ' ', '', [rfReplaceAll]) + ']');
end;
procedure DoProcedure;
var
n: Integer;
S: String;
begin
Result.Add('family=procedure');
S := GetPart(['('], [''], Line);
//concatinate all lines
for n := 0 to Lines.Count - 1 do
S := S + Lines[n];
S := GetPart([''], [')'], S);
Result.Add('args=[' + StringReplace(S, ', ', ',', [rfReplaceAll]) + ']');
end;
procedure DoFunction;
var
n: Integer;
S, Args: String;
begin
Result.Add('family=function');
S := GetPart(['('], [], Line);
//concatinate all lines
for n := 0 to Lines.Count - 1 do
S := S + Lines[n];
Args := GetPart([], [')'], S);
S := GetPart([' : '], [], S);
Result.Add('args=[' + StringReplace(Args, ', ', ',', [rfReplaceAll]) + ']');
Result.Add('result=' + S);
end;
procedure DoClass;
begin
Result.Add('family=class');
Result.Add('ancestor=' + GetPart([': public '], [' '], Line));
end;
begin
Result := TStringList.Create;
if AResultValues = '' then Exit;
Lines := TStringList.Create;
try
Lines.Text := AResultValues;
if Lines.Count = 0 then Exit;
Line := Lines[0];
Lines.Delete(0);
S := GetPart(['type = '], [' '], Line);
if S = '' then Exit;
if Pos(' = class ', Line) > 0
then DoClass
else if S[1] = '^'
then begin
Result.Add('family=pointer');
Result.Add('type=' + GetPart(['^'], [' ='], S));
end
else if S = 'set'
then begin
Result.Add('family=set');
Result.Add('type=' + Copy(Line, 5, Length(Line)));
end
else if S = 'procedure'
then DoProcedure
else if S = 'function'
then DoFunction
else if Pos(' = (', Line) > 0
then DoEnum
else if Pos(' = record', Line) > 0
then DoRecord
else begin
Result.Add('family=simple');
Result.Add('type=' + S);
end;
finally
Lines.Free;
end;
end;
function ParseTypeFromGdb(const ATypeText: PChar; const ATypeTextLen: Integer): TGDBPTypeResult;
var
i: Integer;
CurPtr, LineEndPtr, EndPtr, BaseDeclPtr, DeclPtr, DeclEndPtr: PChar;
HelpPtr, HelpPtr2: PChar;
SubRes: TGDBPTypeResult;
procedure SkipSpaces(var p: PChar); inline;
begin
while (p^ = ' ') do inc(p);
end;
function CheckKeyword: TGDBPTypeResultKind;
begin
Result := ptprkSimple;
// Might be: "set of ", "class", "record =", "array [", '<invalid unnamed"...,
case CurPtr^ of
's', 'S': begin
if (LineEndPtr - CurPtr >= 6 )
and (UpperCase(copy(CurPtr, 1, 7)) = 'SET OF ')
then
Result := ptprkSet;
end;
'r', 'R': begin
if (LineEndPtr - CurPtr >= 5 )
and (UpperCase(copy(CurPtr, 1, 6)) = 'RECORD')
and ((CurPtr+6)^ in [' ', ')', #13, #0])
then
Result := ptprkRecord;
end;
'c', 'C': begin
if (LineEndPtr - CurPtr >= 4 )
and (UpperCase(copy(CurPtr, 1, 5)) = 'CLASS')
and ((CurPtr+5)^ in [' ', ')', #13, #0])
then
Result := ptprkClass;
end;
'a', 'A': begin
if (LineEndPtr - CurPtr >= 5 )
and (UpperCase(copy(CurPtr, 1, 6)) = 'ARRAY ')
then
Result := ptprkArray;
end;
'<': begin
if (LineEndPtr - CurPtr >= 35 )
and (copy(CurPtr, 1, 36) = '<invalid unnamed pascal type code 8>')
then
Result := ptprkSet;
end;
'p', 'P': begin
if (LineEndPtr - CurPtr >= 8 )
and (UpperCase(copy(CurPtr, 1, 9)) = 'PROCEDURE')
and ((CurPtr+9)^ in [' ', '(', ')', #13, #0])
then
Result := ptprkProcedure;
end;
'f', 'F': begin
if (LineEndPtr - CurPtr >= 7 )
and (UpperCase(copy(CurPtr, 1, 8)) = 'FUNCTION')
and ((CurPtr+8)^ in [' ', '(', ')', #13, #0])
then
Result := ptprkFunction;
end;
end;
end;
function CheckIsEnum: Integer;
var
p: PChar;
begin
Result := -1;
if CurPtr^ <> '(' then exit;
p := CurPtr;
while not(p^ in [')', #0]) do inc(p);
if (p <= LineEndPtr) and (p^ = ')') then
Result := p - CurPtr + 1;
end;
procedure SetPCharLen(var ATarget: TPCharWithLen; AStartPtr, AEndPtr: PChar);
begin
ATarget.Ptr := AStartPtr;
ATarget.Len := AEndPtr - AStartPtr + 1;
end;
begin
{$IFDEF DBGMI_TYPE_INFO}
try
{$ENDIF}
Result.Flags := [];
Result.Kind := ptprkError;
Result.Name.Ptr := nil;
Result.Name.Len := 0;
Result.BaseName.Ptr := nil;
Result.BaseName.Len := 0;
Result.Declaration.Ptr := nil;
Result.Declaration.Len := 0;
Result.BaseDeclaration.Ptr := nil;
Result.BaseDeclaration.Len := 0;
Result.PointerCount := 0;
Result.BoundLow.Ptr := nil;
Result.BoundLow.Len := 0;
Result.BoundHigh.Ptr := nil;
Result.BoundHigh.Len := 0;
Result.SubName.Ptr := nil;
Result.SubName.Len := 0;
Result.BaseSubName.Ptr := nil;
Result.BaseSubName.Len := 0;
Result.SubFlags := [];
Result.SubKind := ptprkError;
Result.NestArrayCount := 0;
If (ATypeText = nil) or (ATypeTextLen = 0) then exit;
(* type = [&^][name]
type = [&^][name] = class|record : public
type = [&^][name] = (a,b,c)
type = [&^]array ...
type = [&^]set of [name] = (a,b)
type = [&^](.....)
*)
CurPtr := ATypeText;
EndPtr := ATypeText + ATypeTextLen-1;
while (EndPtr > CurPtr) and (EndPtr^ in [#10, #13, ' ']) do dec (EndPtr);
LineEndPtr := EndPtr;
//limit LineEndPtr to first \n
HelpPtr := CurPtr;
while (true) do begin
if HelpPtr > LineEndPtr - 1 then break;
if (HelpPtr[0] in [#10, #13])
then begin
LineEndPtr := HelpPtr-1;
while (LineEndPtr > CurPtr) and (LineEndPtr^ in [#10, #13, ' ']) do dec (LineEndPtr);
break;
end;
inc(HelpPtr);
end;
BaseDeclPtr := CurPtr;
DeclPtr := BaseDeclPtr;
DeclEndPtr := LineEndPtr;
// Leading ^&
while True do begin
case CurPtr^ of
'^': begin
include(Result.Flags, ptprfPointer);
inc(Result.PointerCount);
end;
'&': include(Result.Flags, ptprfParamByRef);
else break;
end;
inc(CurPtr);
end;
SkipSpaces(CurPtr); // shouldn'tever happen
BaseDeclPtr := CurPtr;
if CurPtr > LineEndPtr then begin
include(Result.Flags, ptprfEmpty);
exit;
end;
// entite type in brackest (), eg ^(array...)
if CurPtr^ = '(' then begin
Include(Result.Flags, ptprfDeclarationInBrackets);
inc(CurPtr);
SkipSpaces(CurPtr); // shouldn'tever happen
BaseDeclPtr := CurPtr;
DeclPtr := CurPtr; // not possible to capture with one line, as closing bracket may be on other line
if DeclEndPtr^ = ')' then dec(DeclEndPtr);
if LineEndPtr^ = ')' then dec(LineEndPtr);
if EndPtr^ = ')' then dec(EndPtr);
end;
SetPCharLen(Result.BaseDeclaration, BaseDeclPtr, DeclEndPtr);
SetPCharLen(Result.Declaration, DeclPtr, DeclEndPtr);
if CurPtr^ = '=' then begin
// skip ' = '
inc(CurPtr);
SkipSpaces(CurPtr);
end
else begin
// process part before ' = '
Result.Kind := CheckKeyword;
if Result.Kind = ptprkSimple
then begin
// we may have type = NAME = ....
HelpPtr := CurPtr;
while (HelpPtr <= LineEndPtr) and not (HelpPtr^ in [#0..#31, ' ']) do inc(HelpPtr);
HelpPtr2 := HelpPtr; // HelpPtr2 = after [name]
SkipSpaces(HelpPtr2);
if (HelpPtr2^ = '=') or // TYPE WITH = (EQUAL)
((HelpPtr^ in [#0, #10, #13]) or (HelpPtr > LineEndPtr))
then begin
// Type without space, use as name
SetPCharLen(Result.Name, DeclPtr, HelpPtr-1);
SetPCharLen(Result.BaseName, BaseDeclPtr, HelpPtr-1);
if (HelpPtr^ in [#0, #10, #13]) or (HelpPtr > LineEndPtr) then exit;
CurPtr := HelpPtr2 + 1; // after ' = '
SkipSpaces(CurPtr);
BaseDeclPtr := CurPtr; // Declaration after ' = '
DeclPtr := CurPtr;
end
else begin
// Type is a declaration with spaces
// (base)declaration is already set
exit;
end;
end;
end;
// after ' = '
i := CheckIsEnum;
if i > 0 then begin
Result.Kind := ptprkEnum;
SetPCharLen(Result.BaseDeclaration, CurPtr, CurPtr+i-1);
SetPCharLen(Result.Declaration, CurPtr, CurPtr+i-1);
exit;
end;
Result.Kind := CheckKeyword;
if Result.Kind = ptprkSimple then begin
Result.Kind := ptprkError;
debugln('** WARNING: ptype info format error: ' + ATypeText);
exit;
end;
// now we should be AT a keyword, we may have a name set already // Enum are handled already too
while LineEndPtr^ = ' ' do dec(LineEndPtr);
case Result.Kind of
ptprkClass: begin
HelpPtr := CurPtr + 5;
SkipSpaces(HelpPtr);
if HelpPtr^ in [#10, #13] then include(Result.Flags, ptprfNoStructure);
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
end;
ptprkRecord: begin
HelpPtr := CurPtr + 6;
SkipSpaces(HelpPtr);
if HelpPtr^ in ['{'] then begin
include(Result.Flags, ptprfNoStructure);
SetPCharLen(Result.Declaration, DeclPtr, CurPtr + 5);
end
else
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
end;
ptprkSet: begin
if CurPtr^ <> '<' then begin;
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
//CurPtr := Result.BaseDeclaration.Ptr + 3;
CurPtr := CurPtr + 6;
SkipSpaces(CurPtr);
if (CurPtr^ = '=') then begin // has enum, no name,
CurPtr := CurPtr + 1;
SkipSpaces(CurPtr);
end;
SetPCharLen(Result.SubName, CurPtr, LineEndPtr);
while (CurPtr^ in ['^', '&']) and (CurPtr < LineEndPtr) do inc(CurPtr); // should not happen
SetPCharLen(Result.BaseSubName, CurPtr, LineEndPtr);
Result.SubKind := ptprkSimple;
end
else begin
Result.Declaration.Ptr := nil;
Result.Declaration.Len := 0;
Result.BaseDeclaration.Ptr := nil;
Result.BaseDeclaration.Len := 0;
end;
end;
ptprkArray: begin
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
SetPCharLen(Result.BaseDeclaration, BaseDeclPtr, LineEndPtr);
CurPtr := CurPtr + 5;
SkipSpaces(CurPtr);
include(Result.Flags, ptprfNoBounds);
include(Result.Flags, ptprfDynArray);
if CurPtr^ = '[' then begin
inc(CurPtr);
HelpPtr := CurPtr;
while (HelpPtr^ in ['-', '0'..'9']) and (HelpPtr < LineEndPtr - 3) do inc (HelpPtr);
if (HelpPtr > CurPtr) and (HelpPtr^ = '.') and ((HelpPtr+1)^ = '.') then begin
HelpPtr2 := HelpPtr + 2;
while (HelpPtr2^ in ['-', '0'..'9']) and (HelpPtr2 < LineEndPtr - 1) do inc (HelpPtr2);
if (HelpPtr2 > HelpPtr) and (HelpPtr2^ = ']') then begin
exclude(Result.Flags, ptprfNoBounds);
Result.BoundLow.Ptr := CurPtr;
Result.BoundLow.Len := HelpPtr - CurPtr;
Result.BoundHigh.Ptr := HelpPtr + 2;
Result.BoundHigh.Len := HelpPtr2 - (HelpPtr + 2);
if (HelpPtr2 - CurPtr <> 5) or (strlcomp(Result.BoundLow.Ptr, PChar('0..-1'), 5) <> 0) then
exclude(Result.Flags, ptprfDynArray);
CurPtr := HelpPtr2 + 1;
end;
end;
end;
SkipSpaces(CurPtr);
if (CurPtr^ in ['o', 'O']) and ((CurPtr+1)^ in ['f', 'F']) then begin
CurPtr := CurPtr + 2;
SkipSpaces(CurPtr);
SubRes := ParseTypeFromGdb(CurPtr, EndPtr - CurPtr + 1);
if SubRes.Kind = ptprkArray then begin
Result.SubName := SubRes.SubName;
Result.BaseSubName := SubRes.BaseSubName;
Result.SubFlags := SubRes.SubFlags;
Result.SubKind := SubRes.SubKind;
Result.NestArrayCount := SubRes.NestArrayCount + 1;
Result.NestArray := SubRes.NestArray;
if length(Result.NestArray) < Result.NestArrayCount
then SetLength(Result.NestArray, Result.NestArrayCount + 3);
Result.NestArray[SubRes.NestArrayCount].Flags := SubRes.Flags;
Result.NestArray[SubRes.NestArrayCount].PointerCount := SubRes.PointerCount;
Result.NestArray[SubRes.NestArrayCount].BoundLow := SubRes.BoundLow;
Result.NestArray[SubRes.NestArrayCount].BoundHigh := SubRes.BoundHigh;
end else begin
Result.SubName := SubRes.Name;
Result.BaseSubName := SubRes.BaseName;
Result.SubFlags := SubRes.Flags;
Result.SubKind := SubRes.Kind;
end;
//SetPCharLen(Result.SubName, CurPtr, LineEndPtr);
//while (CurPtr^ in ['^', '&']) and (CurPtr < LineEndPtr) do inc(CurPtr);
//SetPCharLen(Result.BaseSubName, CurPtr, LineEndPtr);
end;
end;
ptprkProcedure, ptprkFunction: begin
SetPCharLen(Result.Declaration, DeclPtr, LineEndPtr);
end;
end;
{$IFDEF DBGMI_TYPE_INFO}
finally
DebugLn(['ParseTypeFromGdb: Flags=', dbgs(Result.Flags), ' Kind=', dbgs(Result.Kind), ' Name="', PCLenToString(Result.Name),'"' ]);
end;
{$ENDIF}
end;
function ParseTypeFromGdb(const ATypeText: string): TGDBPTypeResult;
var
i: SizeInt;
begin
i := pos('type = ', ATypeText);
if i < 1
then Result := ParseTypeFromGdb(PChar(ATypeText), length(ATypeText))
else Result := ParseTypeFromGdb((@ATypeText[i])+7, length(ATypeText)-6-i);
Result.GdbDescription := ATypeText;
end;
function dbgs(AFlag: TGDBPTypeResultFlag): string;
begin
writestr(Result, AFlag);
end;
function dbgs(AFlags: TGDBPTypeResultFlags): string;
var
i: TGDBPTypeResultFlag;
begin
for i := low(TGDBPTypeResultFlags) to high(TGDBPTypeResultFlags) do
if i in AFlags then begin
if Result <> '' then Result := Result + ', ';
Result := Result + dbgs(i);
end;
if Result <> '' then Result := '[' + Result + ']';
end;
function dbgs(AKind: TGDBPTypeResultKind): string;
begin
writestr(Result, AKind);
end;
function dbgs(AReqType: TGDBCommandRequestType): string;
begin
WriteStr(Result, AReqType);
end;
function dbgs(AReq: TGDBPTypeRequest): string;
begin
Result := 'Req="'+AReq.Request+'" type='+dbgs(AReq.ReqType)
+' HasNext='+dbgs(AReq.Next <> nil)
;
end;
{ TGDBExpressionPartArrayIdx }
function TGDBExpressionPartArrayIdx.GetArrayPTypeIsDeRef: boolean;
begin
Result := (FPTypeReq.Result.Kind <> ptprkArray);
end;
function TGDBExpressionPartArrayIdx.GetArrayPTypeIsPointer: boolean;
begin
if FArrayPTypeNestIdx < 0 then begin
if ArrayPTypeIsDeRef
then Result := True
else Result := ptprfPointer in FPTypeReq.Result.Flags;
end
else begin
Result := ptprfPointer in ArrayPTypeResult.NestArray[FArrayPTypeNestIdx].Flags;
end;
end;
function TGDBExpressionPartArrayIdx.GetArrayPTypeResult: TGDBPTypeResult;
begin
Result := FPTypeReq.Result;
if (Result.Kind <> ptprkArray) then
Result := FPTypeDeRefReq.Result;
end;
procedure TGDBExpressionPartArrayIdx.Init;
begin
inherited Init;
FPTypeReq.Result.Kind := ptprkNotEvaluated;
FPTypeDeRefReq.Result.Kind := ptprkNotEvaluated;
FPTypeIndexReq.Result.Kind := ptprkNotEvaluated;
FVarParam := False;
FArrayPTypeNestidx := -1;
FArrayPTypePointerIdx := 0;
end;
procedure TGDBExpressionPartArrayIdx.InitReq(var AReqPtr: PGDBPTypeRequest; AReqText: String);
begin
FPTypeReq.Request := AReqText;
FPTypeReq.Error := '';
FPTypeReq.ReqType := gcrtPType;
FPTypeReq.Next := AReqPtr;
FPTypeReq.Result.Kind := ptprkError;
AReqPtr := @FPTypeReq;
end;
procedure TGDBExpressionPartArrayIdx.InitDeRefReq(var AReqPtr: PGDBPTypeRequest;
AReqText: String);
begin
FPTypeDeRefReq.Request := AReqText;
FPTypeDeRefReq.Error := '';
FPTypeDeRefReq.ReqType := gcrtPType;
FPTypeDeRefReq.Next := AReqPtr;
FPTypeDeRefReq.Result.Kind := ptprkError;
AReqPtr := @FPTypeDeRefReq;
end;
procedure TGDBExpressionPartArrayIdx.InitIndexReq(var AReqPtr: PGDBPTypeRequest);
begin
FPTypeIndexReq.Request := '-data-evaluate-expression ' + GetPlainText;
FPTypeIndexReq.Error := '';
FPTypeIndexReq.ReqType := gcrtEvalExpr;
FPTypeIndexReq.Next := AReqPtr;
FPTypeIndexReq.Result.Kind := ptprkError;
AReqPtr := @FPTypeIndexReq;
end;
function TGDBExpressionPartArrayIdx.GetTextFixed(AStringFixed: Boolean): String;
begin
if AStringFixed then begin
if FExpressionPart = nil
then Result := PCLenPartToString(FText, 1, FText.Len-2)
else Result := FExpressionPart.Text;
Result := FText.Ptr^ + Result + '-1' + (FText.Ptr + FText.Len-1)^;
end
else
Result := inherited GetTextFixed(AStringFixed);
end;
{ TGDBExpressionPartList }
function TGDBExpressionPartList.AddList(APartList: TGDBExpressionPartList): Integer;
var
i: Integer;
begin
Result := -1;
if APartList.PartCount = 0 then exit;
Result := FList.add(APartList.Parts[0]);
for i := 1 to APartList.PartCount - 1 do
FList.add(APartList.Parts[i]);
end;
{ TGDBExpressionPartArray }
function TGDBExpressionPartArray.GetIndexParts(Index: Integer): TGDBExpressionPartArrayIdx;
begin
Result := TGDBExpressionPartArrayIdx(Parts[Index+1]);
end;
function TGDBExpressionPartArray.GetTextFixed(AStringFixed: Boolean): String;
begin
Result := GetTextToIdx(IndexCount-1, AStringFixed);
end;
function TGDBExpressionPartArray.GetTextToIdx(AIdx: Integer; AStrFixed: Boolean = False): String;
function GetPointerCast(AnIdxPart: TGDBExpressionPartArrayIdx; out PointerCnt: Integer): String;
var
PTRes: TGDBPTypeResult;
i: Integer;
begin
Result := '';
PointerCnt := 0;
if not AnIdxPart.ArrayPTypeIsPointer then exit;
PTRes := AnIdxPart.ArrayPTypeResult;
if PTRes.SubName.Len = 0 then exit;
i := PTRes.NestArrayCount - 1;
if i >= 0 then begin
while (i >= 0) and (ptprfPointer in PTRes.NestArray[i].Flags) do dec(i);
if i >= 0 then exit; // cant cast, if contains static array
PointerCnt := PTRes.NestArrayCount+1;
Result := StringOfChar('^', PointerCnt) + PCLenToString(PTRes.SubName);
exit;
end;
PointerCnt := PTRes.PointerCount;
// If PTRes is the result of an extra de-ref in the ptype, then we need to add that pointer back
if AnIdxPart.ArrayPTypeIsDeRef then
inc(PointerCnt);
Result := StringOfChar('^', PointerCnt) + PCLenToString(PTRes.SubName);
end;
var
i, j, PCastCnt: Integer;
IdxPart: TGDBExpressionPartArrayIdx;
PTResult: TGDBPTypeResult;
NeedTCast: Boolean;
s: String;
begin
Result := Parts[0].Text;
PCastCnt := 0;
if AIdx < 0 then exit;
for i := 0 to AIdx do begin
IdxPart := IndexPart[i];
PTResult := IdxPart.ArrayPTypeResult;
if PCastCnt > 0 then dec(PCastCnt);
if not (PTResult.Kind = ptprkArray)
then begin
// maybe pointer with index access
if AStrFixed and (i = IndexCount - 1)
then Result := Result + IdxPart.TextStrFixed
else Result := Result + IdxPart.Text;
continue;
end;
if ((PTResult.NestArrayCount > 0) and (IdxPart.ArrayPTypeNestIdx <> PTResult.NestArrayCount-1)) or
(IdxPart.ArrayPTypePointerIdx > 0)
then begin
// nested array / no named type known
if (PCastCnt = 0) and IdxPart.ArrayPTypeIsPointer
then Result := Result + '^';
Result := Result + IdxPart.Text;
continue;
end;
NeedTCast := FNeedTypeCast and (i = IndexCount-1);
if IdxPart.ArrayPTypeIsPointer
then begin
//dyn array
s := '';
if IdxPart.VarParam then
s := GetPointerCast(IdxPart, j);
if s <> '' // IdxPart.VarParam and (PTResult.SubName.Len > 0) // var param can only be set for the un-inxed variable
then begin
// fpc 2.4.4 Var-param dynarray
// var param are marked with a "&" in fpc 2.4. They are a semi automatic pointer.
// 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
// For single dyn array: ^Foo(var)[1]
// 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
Result := s + '(' + Result + ')';
NeedTCast := False;
PCastCnt := j;
end
else
if (PCastCnt = 0) then
Result := Result + '^';
end;
Result := Result + IdxPart.Text;
if NeedTCast and (PTResult.SubName.Len > 0)
then
Result := PCLenToString(PTResult.SubName) + '(' + Result + ')';
end;
end;
function TGDBExpressionPartArray.IndexCount: Integer;
begin
Result := PartCount - 1;
end;
constructor TGDBExpressionPartArray.Create(ALeadExpresion: TGDBExpressionPart);
begin
inherited Create;
FNeedTypeCast := False;
Add(ALeadExpresion);
end;
function TGDBExpressionPartArray.AddIndex(APart: TGDBExpressionPartArrayIdx): Integer;
begin
Result := Add(APart);
end;
function TGDBExpressionPartArray.NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean;
function IsNumber(s: String): Boolean;
var i: Integer;
begin
i := Length(s);
while (i >= 1) and (s[i] in ['0'..'9']) do dec(i);
Result := i = 0;
end;
var
i, j: Integer;
IdxPart, IdxPart2: TGDBExpressionPartArrayIdx;
PTReq, PTDeRefReq: TGDBPTypeRequest;
ArrRes: TGDBPTypeResult;
ResultList: TGDBMINameValueList;
s: String;
begin
Result := False;
for i := 1 to PartCount - 1 do
if Parts[i].NeedValidation(AReqPtr) then
Result := True;
if Parts[0].NeedValidation(AReqPtr)
then begin
Result := True;
exit;
end;
i := 0;
while i < IndexCount do begin
IdxPart := IndexPart[i];
PTReq := IdxPart.PTypeReq;
if PTReq.Result.Kind = ptprkError
then exit; // no way to find more info
if PTReq.Result.Kind = ptprkNotEvaluated
then begin
IdxPart.VarParam := False;
IdxPart.InitReq(AReqPtr, 'ptype ' + GetTextToIdx(i-1));
Result := True;
exit;
end
else
if (not IdxPart.VarParam) and (ptprfParamByRef in PTReq.Result.Flags)
then begin
// FPC 2.2.4 encoded "var param" in a special way, and we need an extra deref)
IdxPart.VarParam := True;
IdxPart.InitReq(AReqPtr, 'ptype ' + GetTextToIdx(i-1) + '^');
Result := True;
exit;
end;
(* With Dwarf gdb may return "type = ^TFoo" for an array
And the for the derefferenced expr "type = array of TFoo"
*)
PTDeRefReq := IdxPart.PTypeDeRefReq;
if (PTReq.Result.Kind <> ptprkArray) and
(ptprfPointer in PTReq.Result.Flags) and
(PTDeRefReq.Result.Kind = ptprkNotEvaluated)
then begin
if IdxPart.VarParam
then IdxPart.InitDeRefReq(AReqPtr, 'ptype ' + GetTextToIdx(i-1) + '^^')
else IdxPart.InitDeRefReq(AReqPtr, 'ptype ' + GetTextToIdx(i-1) + '^');
Result := True;
exit;
end;
// we may have nested array (dyn array only):
// - ^^(array ...)
// - array ... oaf array
// A combination of both is not expected
ArrRes := IdxPart.ArrayPTypeResult;
if (ArrRes.Kind = ptprkArray) and (ArrRes.NestArrayCount > 0) then begin
j := ArrRes.NestArrayCount;
while j > 0 do begin
inc(i);
dec(j);
if i >= IndexCount then break;
IdxPart2 := IndexPart[i];
IdxPart2.PTypeReq := IdxPart.PTypeReq;
IdxPart2.PTypeDeRefReq := IdxPart.PTypeDeRefReq;
IdxPart2.ArrayPTypeNestIdx := j;
end;
end
else
if (ArrRes.Kind = ptprkArray) and (ArrRes.PointerCount > 1) then begin
j := ArrRes.PointerCount - 1;
while j > 0 do begin
inc(i);
dec(j);
if i >= IndexCount then break;
IdxPart2 := IndexPart[i];
IdxPart2.PTypeReq := IdxPart.PTypeReq;
IdxPart2.PTypeDeRefReq := IdxPart.PTypeDeRefReq;
IdxPart2.ArrayPTypePointerIdx := j;
end;
end;
inc(i);
end;
if IndexCount=0 then exit;
// check if we may access a char in a string
IdxPart := IndexPart[IndexCount-1];
PTReq := IdxPart.PTypeReq;
if (PTReq.Result.Kind = ptprkSimple) and
not(IdxPart.PTypeDeRefReq.Result.Kind = ptprkArray)
then begin
s := LowerCase(PCLenToString(PTReq.Result.BaseName));
if (ptprfPointer in PTReq.Result.Flags) and
( ( s = 'char') or (s = 'character') or (s = 'wchar') or (s = 'widechar') )
then begin
if IsNumber(IdxPart.GetPlainText)
then begin
FMaybeString := True;
end
else begin
PTReq := IdxPart.PTypeIndexReq;
if PTReq.Result.Kind = ptprkNotEvaluated
then begin
IdxPart.InitIndexReq(AReqPtr);
Result := True;
exit;
end;
if (PTReq.Result.Kind = ptprkSimple)
then begin
ResultList := TGDBMINameValueList.Create(PTReq.Result.GdbDescription);
FMaybeString := IsNumber(ResultList.Values['value']);
ResultList.Free;
end;
end;
end;
end;
end;
function TGDBExpressionPartArray.MayNeedStringFix: Boolean;
begin
Result := FMaybeString;
if not Result then
Result := inherited MayNeedStringFix;
end;
{ TGDBExpressionPartCastCall }
constructor TGDBExpressionPartCastCall.Create(ALeadExpresion: TGDBExpressionPart);
begin
inherited Create;
Add(ALeadExpresion);
end;
function TGDBExpressionPartCastCall.AddBrackets(APart: TGDBExpressionPart): Integer;
begin
Result := Add(APart);
end;
{ TGDBExpressionPartBracketed }
function TGDBExpressionPartBracketed.GetTextFixed(AStringFixed: Boolean): String;
begin
if FExpressionPart = nil
then Result := inherited GetTextFixed(AStringFixed)
else Result := FText.Ptr^ + FExpressionPart.GetTextFixed(AStringFixed) + (FText.Ptr + FText.Len-1)^;
end;
function TGDBExpressionPartBracketed.GetPlainText: String;
begin
if FExpressionPart = nil
then Result := PCLenPartToString(FText, 1, FText.Len-2)
else Result := FExpressionPart.Text;
end;
constructor TGDBExpressionPartBracketed.Create(AText: PChar; ATextLen: Integer);
begin
CreateSimple(AText, ATextLen);
FExpressionPart := ParseExpression(FText.Ptr+1, FText.Len-2);
end;
{ TGDBExpressionPart }
function TGDBExpressionPart.GetTextFixed(AStringFixed: Boolean): String;
begin
Result := PCLenToString(FText);
end;
function TGDBExpressionPart.GetText: String;
begin
Result := GetTextFixed(False);
end;
function TGDBExpressionPart.ParseExpression(AText: PChar; ATextLen: Integer): TGDBExpressionPart;
const
// include "." (dots). currently there is no need to break expressions like "foo.bar"
// Include "^" (deref)
// do NOT include "@", it is applied after []() resolution
WordChar = [' ', #9, 'a'..'z', 'A'..'Z', '0'..'9', '_', '.', '^'];
var
CurPtr, EndPtr: PChar;
CurPartPtr: PChar;
procedure SkipSpaces;
begin
while (CurPtr < EndPtr) and (CurPtr^ in [#9, ' ']) do inc(CurPtr);
end;
procedure ScanToWordEnd;
begin
// include "." (dots). currently there is no need to break expressions like "foo.bar"
// Include "^" (deref)
while (CurPtr < EndPtr) and (CurPtr^ in WordChar)
do inc(CurPtr);
end;
procedure ScanToWordStart;
begin
while (CurPtr < EndPtr) and not (CurPtr^ in WordChar)
do inc(CurPtr);
end;
function ScanToCallCastEnd: Boolean;
var
i: Integer;
begin
i := 0;
while (CurPtr < EndPtr) do begin
case CurPtr^ of
'(': inc(i);
')': begin
dec(i);
inc(CurPtr);
if i = 0
then break
else continue;
end;
end;
inc(CurPtr);
end;
Result := i = 0;
end;
function ScanToIndexEnd: Boolean;
var
i: Integer;
begin
i := 0;
while (CurPtr < EndPtr) do begin
case CurPtr^ of
'[': inc(i);
']': begin
dec(i);
inc(CurPtr);
if i = 0
then break
else continue;
end;
end;
inc(CurPtr);
end;
Result := i = 0;
end;
procedure AddExpPart(aList: TGDBExpressionPartList);
var
NewList: TGDBExpressionPartList;
begin
if aList.PartCount = 0 then exit;
if (aList.PartCount = 1) and (Result = nil) then begin
Result := aList.Parts[0];
aList.ClearShared;
exit;
end;
If Result = nil
then Result := TGDBExpressionPartList.Create
else
if not (Result is TGDBExpressionPartList)
then begin
NewList := TGDBExpressionPartList.Create;
NewList.Add(Result);
Result := NewList;
end;
TGDBExpressionPartList(Result).AddList(aList);
aList.ClearShared;
end;
function MoveListToCopy(aList: TGDBExpressionPartList): TGDBExpressionPart;
begin
if aList.PartCount = 1
then begin
Result := aList.Parts[0];
end
else begin
Result := TGDBExpressionPartList.Create;
TGDBExpressionPartList(Result).AddList(aList);
end;
aList.ClearShared;
end;
var
CurList: TGDBExpressionPartList;
CurArray: TGDBExpressionPartArray;
CurCast: TGDBExpressionPartCastCall;
begin
Result := nil;
CurPtr := AText;
EndPtr := AText + ATextLen;
while (CurPtr < EndPtr) and not(CurPtr^ in ['[', '(']) do inc(CurPtr);
if CurPtr = EndPtr then exit; // no fixup needed
CurPtr := AText;
CurArray := nil;
CurList:= TGDBExpressionPartList.Create;
while CurPtr < EndPtr do begin
if CurPtr^ in WordChar
then begin
if CurArray <> nil then CurArray.NeedTypeCast := True;
CurArray := nil;
CurPartPtr := CurPtr;
ScanToWordEnd;
CurList.Add(TGDBExpression.CreateSimple(CurPartPtr, CurPtr - CurPartPtr));
end
else
if (CurList.PartCount > 0) and (CurPtr^ = '[')
then begin
if CurArray <> nil then CurArray.NeedTypeCast := True;
CurArray := TGDBExpressionPartArray.Create(MoveListToCopy(CurList));
CurList.Add(CurArray);
while (CurPtr^ = '[') do begin
CurPartPtr := CurPtr;
if not ScanToIndexEnd then break; // broken expression, do not attempt to do anything
CurArray.AddIndex(TGDBExpressionPartArrayIdx.Create(CurPartPtr, CurPtr - CurPartPtr));
SkipSpaces;
end;
end
else
if (CurList.PartCount > 0) and (CurPtr^ = '(')
then begin
if CurArray <> nil then CurArray.NeedTypeCast := True;
CurArray := nil;
CurCast := TGDBExpressionPartCastCall.Create(MoveListToCopy(CurList));
CurList.Add(CurCast);
CurPartPtr := CurPtr;
if not ScanToCallCastEnd then break; // broken expression, do not attempt to do anything
CurCast.AddBrackets(TGDBExpressionPartBracketed.Create(CurPartPtr, CurPtr - CurPartPtr));
end
else begin
CurArray := nil;
CurPartPtr := CurPtr;
ScanToWordStart;
CurList.Add(TGDBExpression.CreateSimple(CurPartPtr, CurPtr - CurPartPtr));
AddExpPart(CurList);
end;
end;
AddExpPart(CurList);
CurList.Free;
if CurPtr < EndPtr then debugln(['Scan aborted: ', PCLenToString(FText)]);
if CurPtr < EndPtr then FreeAndNil(Result);
end;
procedure TGDBExpressionPart.Init;
begin
//
end;
function TGDBExpressionPart.NeedValidation(var AReqPtr: PGDBPTypeRequest): Boolean;
var
i: Integer;
begin
Result := False;
for i := 0 to PartCount - 1 do
if Parts[i].NeedValidation(AReqPtr) then
Result := True;
end;
function TGDBExpressionPart.MayNeedStringFix: Boolean;
var
i: Integer;
begin
Result := False;
for i := 0 to PartCount - 1 do
if Parts[i].MayNeedStringFix then
Result := True;
end;
constructor TGDBExpressionPart.Create;
begin
Init;
end;
function TGDBExpressionPart.GetTextStrFixed: String;
begin
Result := GetTextFixed(True);
end;
function TGDBExpressionPart.GetParts(Index: Integer): TGDBExpressionPart;
begin
Result := nil;
end;
function TGDBExpressionPart.PartCount: Integer;
begin
Result := 0;
end;
{ TGDBExpressionPartListBase }
function TGDBExpressionPartListBase.GetParts(Index: Integer): TGDBExpressionPart;
begin
Result := TGDBExpressionPart(FList[Index]);
end;
function TGDBExpressionPartListBase.GetTextFixed(AStringFixed: Boolean): String;
var
i: Integer;
begin
Result := '';
for i := 0 to PartCount - 1 do
Result := Result + Parts[i].GetTextFixed(AStringFixed);
end;
constructor TGDBExpressionPartListBase.Create;
begin
inherited Create;
FList := TFPList.Create;
end;
destructor TGDBExpressionPartListBase.Destroy;
begin
Clear;
FreeAndNil(FList);
inherited Destroy;
end;
procedure TGDBExpressionPartListBase.Clear;
begin
while FList.Count > 0 do begin
TGDBExpressionPart(Flist[0]).Free;
FList.Delete(0);
end;
end;
procedure TGDBExpressionPartListBase.ClearShared;
begin
FList.Clear;
end;
function TGDBExpressionPartListBase.Add(APart: TGDBExpressionPart): Integer;
begin
Result := FList.Add(APart);
end;
function TGDBExpressionPartListBase.PartCount: Integer;
begin
Result := FList.Count;
end;
{ TGDBExpression }
function TGDBExpression.GetTextFixed(AStringFixed: Boolean): String;
begin
if FExpressionPart = nil
then Result := inherited GetTextFixed(AStringFixed)
else Result := FExpressionPart.GetTextFixed(AStringFixed);
end;
function TGDBExpression.GetParts(Index: Integer): TGDBExpressionPart;
begin
Result := nil;
if FExpressionPart = nil then exit;
if FExpressionPart is TGDBExpressionPartList
then Result := FExpressionPart.Parts[Index]
else Result := FExpressionPart;
end;
constructor TGDBExpression.CreateSimple(AText: PChar; ATextLen: Integer);
begin
inherited Create;
// not to be parsed
FExpressionPart := nil;
FText.Ptr := AText;
FText.Len := ATextLen;
end;
constructor TGDBExpression.Create(AText: PChar; ATextLen: Integer);
begin
CreateSimple(AText, ATextLen);
FExpressionPart := ParseExpression(FText.Ptr, FText.Len);
end;
constructor TGDBExpression.Create(ATextStr: String);
begin
FTextStr := ATextStr;
Create(PChar(FTextStr), length(FTextStr));
end;
destructor TGDBExpression.Destroy;
begin
FreeAndNil(FExpressionPart);
inherited Destroy;
end;
function TGDBExpression.PartCount: Integer;
begin
Result := 0;
if FExpressionPart = nil then exit;
if FExpressionPart is TGDBExpressionPartList
then Result := FExpressionPart.PartCount
else Result := 1;
end;
{ TGDBPTypeRequestCache }
function TGDBPTypeRequestCache.GetRequest(Index: Integer): TGDBPTypeRequest;
begin
Result := TGDBPTypeRequestCacheEntry(FList[Index]).FRequest;
end;
constructor TGDBPTypeRequestCache.Create;
begin
FList := TFPList.Create;
end;
destructor TGDBPTypeRequestCache.Destroy;
begin
Clear;
inherited Destroy;
FreeAndNil(FList);
end;
procedure TGDBPTypeRequestCache.Clear;
begin
while FList.Count > 0 do begin
TGDBPTypeRequestCacheEntry(FList[0]).Free;
FList.Delete(0);
end;
end;
function TGDBPTypeRequestCache.IndexOf(AThreadId, AStackFrame: Integer;
ARequest: TGDBPTypeRequest): Integer;
var
e: TGDBPTypeRequestCacheEntry;
begin
Result := FList.Count - 1;
while Result >= 0 do begin
e := TGDBPTypeRequestCacheEntry(FList[Result]);
if (e.ThreadId = AThreadId) and (e.StackFrame = AStackFrame) and
(e.Request.Request =ARequest.Request) and
(e.Request.ReqType =ARequest.ReqType)
then
exit;
dec(Result);
end;
end;
procedure TGDBPTypeRequestCache.Add(AThreadId, AStackFrame: Integer;
ARequest: TGDBPTypeRequest);
var
e: TGDBPTypeRequestCacheEntry;
begin
e := TGDBPTypeRequestCacheEntry.Create;
e.FThreadId := AThreadId;
e.FStackFrame := AStackFrame;
e.FRequest := ARequest;
e.FRequest.Next := nil;
FList.Add(e);
end;
{ TGDBPType }
procedure TGDBType.AddTypeReq(var AReq: TGDBPTypeRequest; const ACmd: string = '');
begin
AReq.Result.Kind := ptprkError;
AReq.Request := ACmd;
AReq.Error := '';
AReq.Next := FEvalRequest;
FEvalRequest := @AReq;
if FLastEvalRequest = nil then
FLastEvalRequest := @AReq;
end;
procedure TGDBType.AddSubType(ASubType: TGDBType);
begin
if ASubType.ProcessExpression then
exit;
ASubType.FNextProcessingSubType := FFirstProcessingSubType;
FFirstProcessingSubType := ASubType;
end;
function TGDBType.GetIsFinished: Boolean;
begin
Result := FProcessState = gtpsFinished;
end;
function TGDBType.RequireRequests(ARequired: TGDBTypeProcessRequests; ACustomData: String = ''): Boolean;
function ApplyBrackets(e: string): string;
var
i: Integer;
f: Boolean;
begin
Result := e;
if (e='') or ( (e[1] = '(') and (e[length(e)] = ')') ) then exit;
f := False;
for i := 1 to length(e) do
f := f or not(e[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']);
if f then
Result := '(' + Result + ')';
end;
function GetReqText(AReq: TGDBTypeProcessRequest): String;
begin
case areq of
gptrPTypeExpr: Result := 'ptype ' + FExpression;
gptrWhatisExpr: Result := 'whatis ' + FExpression;
gptrPTypeOfWhatis: Result := 'ptype ' + PCLenToString(FReqResults[gptrWhatisExpr].Result.BaseName);
gptrPTypeExprDeRef: Result := 'ptype ' + ApplyBrackets(FExpression) + '^';
gptrPTypeExprDeDeRef: Result := 'ptype ' + ApplyBrackets(FExpression) + '^^';
gptrEvalExpr: Result := '-data-evaluate-expression '+FExpression;
gptrEvalExprDeRef: Result := '-data-evaluate-expression '+FExpression+'^';
gptrEvalExprCast: Result := '-data-evaluate-expression '+InternalTypeName+'('+FExpression+')';
gptrEvalExpr2: Result := '-data-evaluate-expression '+ACustomData;
gptrEvalExprDeRef2: Result := '-data-evaluate-expression '+ACustomData+'^';
gptrEvalExprCast2: Result := '-data-evaluate-expression '+InternalTypeName+'('+ACustomData+')';
gptrPtypeCustomFixCast, gptrPtypeCustomAutoCast, gptrPtypeCustomAutoCast2:
Result := 'ptype ' + ACustomData;
gptrInstanceClassName: Result := '-data-evaluate-expression (^^^char('+FExpression+')^+3)^';
end;
end;
var
NeededReq: TGDBTypeProcessRequests;
i: TGDBTypeProcessRequest;
begin
NeededReq := ARequired - FProccesReuestsMade;
Result := NeededReq = [];
if Result then exit;
if (gptrPTypeOfWhatis in NeededReq) and not (gptrWhatisExpr in FProccesReuestsMade)
then begin
Exclude(NeededReq, gptrPTypeOfWhatis);
Include(NeededReq, gptrWhatisExpr);
end;
FProccesReuestsMade := FProccesReuestsMade + NeededReq;
for i := low(TGDBTypeProcessRequest) to high(TGDBTypeProcessRequest) do
if i in NeededReq then begin
AddTypeReq(FReqResults[i], GetReqText(i));
if i in [gptrEvalExpr, gptrEvalExprDeRef, gptrEvalExprCast, gptrInstanceClassName]
then FReqResults[i].ReqType := gcrtEvalExpr
else FReqResults[i].ReqType := gcrtPType;
end;
end;
function TGDBType.IsReqError(AReqType: TGDBTypeProcessRequest; CheckResKind: Boolean = True): Boolean;
begin
Result := (not (AReqType in FProccesReuestsMade))
or (FReqResults[AReqType].Error <> '')
or (CheckResKind and (FReqResults[AReqType].Result.Kind = ptprkError));
end;
procedure TGDBType.Init;
begin
inherited Init;
FProcessState := gtpsFinished;
FParsedExpression := nil;
end;
constructor TGDBType.CreateForExpression(const AnExpression: string;
const AFlags: TGDBTypeCreationFlags; AFormat: TWatchDisplayFormat = wdfDefault);
begin
Create(skSimple, ''); // initialize
FInternalTypeName := '';
FEvalError := False;
FExpression := AnExpression;
FOrigExpression := FExpression;
FCreationFlags := AFlags;
FExprEvaluateFormat := AFormat;
FEvalRequest := nil;
FFirstProcessingSubType := nil;
FNextProcessingSubType := nil;
FProcessState := gtpsInitial;
FHasExprEvaluatedAsText := False;
FHasTypeCastFix := False;
FHasAutoTypeCastFix := False;
FAutoTypeCastName := '';
end;
destructor TGDBType.Destroy;
begin
inherited Destroy;
FreeAndNil(FTypeInfoAncestor);
FreeAndNil(FTypeInfoArrayExpression);
FreeAndNil(FParsedExpression);
end;
function TGDBType.ProcessExpression: Boolean;
var
Lines: TStringList;
procedure ProcessInitialSimple; forward;
procedure ProcessSimplePointer; forward;
function ClearAmpersand(s: string): string;
var i: Integer;
begin
Result := s;
i := pos('&', Result);
if i > 0 then delete(Result, i, 1);
end;
procedure SetTypNameFromReq(AReqType: TGDBTypeProcessRequest;
AnUseBaseName: Boolean = False; ADefaultName: String = '');
begin
if IsReqError(AReqType) or (FReqResults[AReqType].Result.BaseName.Len = 0)
then AReqType := gptrPTypeExpr;
if AnUseBaseName
then FTypeName := PCLenToString(FReqResults[AReqType].Result.BaseName)
else FTypeName := ClearAmpersand(PCLenToString(FReqResults[AReqType].Result.Name));
if FTypeName = ''
then FTypeName := ADefaultName;
FInternalTypeName := FTypeName;
end;
Procedure InitLinesFrom(AReq: TGDBPTypeRequest);
begin
FreeAndNil(Lines);
Lines := TStringList.Create;
Lines.Text := AReq.Result.GdbDescription;
end;
procedure DoEnum;
var
S: String;
begin
FKind := skEnum;
S := PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration);
S := GetPart(['('], [')'], S);
if (S = '') or (S = '...') then
exit;
FMembers := TStringList.Create;
FMembers.Text := StringReplace(S, ' ', #13#10, [rfReplaceAll]);
end;
procedure DoProcedure;
var
S: String;
begin
FKind := skProcedure;
S := PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration);
S := GetPart(['('], [')'], S);
if (S = '') then
exit;
FArguments := TGDBTypes.CreateFromCSV(S);
end;
procedure DoFunction;
var
S: String;
begin
FKind := skFunction;
S := PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration);
S := GetPart(['('], [')'], S);
if (S = '') then
exit;
FArguments := TGDBTypes.CreateFromCSV(S);
S := PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration);
FResult := TGDBType.Create(skSimple, GetPart([' : '], [], S));
end;
procedure DoSet;
var
S: String;
begin
FKind := skSet;
S := PCLenToString(FReqResults[gptrPTypeExpr].Result.Declaration);
S := GetPart(['('], [')'], S);
if (S = '') or (S = '...') then
exit;
FMembers := TStringList.Create;
FMembers.Text := StringReplace(StringReplace(S, ',', #13#10, [rfReplaceAll]), ' ', '', [rfReplaceAll]);
end;
{%region * Record * }
procedure DoRecord;
var
n: Integer;
S, S1, S2: String;
Field: TDBGField;
begin
if (FTypeName = 'Variant') or
(FTypeName = 'VARIANT') then
FKind := skVariant
else
if (FTypeName = 'ShortString') or
(FTypeName = 'SHORTSTRING') or
(FTypeName = '&ShortString') then
FKind := skSimple
else
FKind := skRecord;
FFields := TDBGFields.Create;
InitLinesFrom(FReqResults[gptrPTypeExpr]);
//concatenate all lines and skip last end
for n := 1 to Lines.Count - 2 do begin
S := Lines[n];
S1 := Trim(GetPart([' '], [':'], S));
S2 := Trim(GetPart([':'], [';'], S));
Field := TDBGField.Create(
S1,
TGDBType.Create(skSimple, S2),
flPublic
);
FFields.Add(Field);
end;
end;
{%endregion * Record * }
{%region * Class * }
procedure DoClass;
var
n, i: Integer;
S, S2: String;
Name: String;
DBGType: TDBGType;
Location: TDBGFieldLocation;
Flags: TDBGFieldFlags;
begin
include(FAttributes, saInternalPointer);
FKind := skClass;
InitLinesFrom(FReqResults[gptrPTypeExpr]);
FFields := TDBGFields.Create;
if Lines.Count < 1 then exit;
s := Lines[0];
FAncestor := GetPart([': public '], [' '], s);
Location := flPublished;
n := 0;
while n < Lines.Count - 2 do
begin
inc(n);
S := Lines[n];
if S = '' then Continue;
if S = 'end' then break;
if S = ' private' then Location := flPrivate
else if S = ' protected' then Location := flProtected
else if S = ' public' then Location := flPublic
else if S = ' published' then Location := flPublished
else begin
Flags := [];
if Pos(' procedure ', S) > 0
then begin
Name := GetPart(['procedure '], [' ', ';'], S);
DBGType := TGDBType.Create(
skProcedure,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
end
else if Pos(' destructor ~', S) > 0
then begin
Name := GetPart(['destructor ~'], [' ', ';'], S);
DBGType := TGDBType.Create(
skProcedure,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
Include(Flags, ffDestructor);
end
else if Pos(' constructor ', S) > 0
then begin
Name := GetPart(['constructor '], [' ', ';'], S);
DBGType := TGDBType.Create(
skFunction,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S)),
TGDBType.Create(skSimple, GetPart([' : '], [';'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
Include(Flags, ffConstructor);
end
else if Pos(' function ', S) > 0
then begin
Name := GetPart(['function '], [' ', ';'], S);
DBGType := TGDBType.Create(
skFunction,
TGDBTypes.CreateFromCSV(GetPart(['('], [')'], S)),
TGDBType.Create(skSimple, GetPart([' : '], [';'], S))
);
if GetPart(['; '], [';'], S) = 'virtual'
then Flags := [ffVirtual];
end
else begin
Name := GetPart([' '], [' '], S);
S2 := GetPart([' : '], [';'], S);
if (lowercase(copy(S2, 1, 7)) = 'record ') then begin
i := 1;
while (n < Lines.Count - 2) and (i > 0) do
begin
inc(n);
S := Lines[n];
if S = '' then Continue;
if pos(': record ', S) > 0 then inc(i);
if pos(' end;', S) > 0 then dec(i);
S2 := S2 + ' ' + Trim(S);
end;
end;
DBGType := TGDBType.Create(skSimple, S2);
end;
FFields.Add(TDBGField.Create(Name, DBGType, Location, Flags, FTypeName));
end;
end;
end;
procedure ProcessClassPointer;
begin
FProcessState := gtpsClassPointer;
if not RequireRequests([gptrWhatisExpr]) then
exit;
FKind := skPointer;
SetTypNameFromReq(gptrWhatisExpr);
Result := True;
// ====> DONE
end;
procedure ProcessClassAncestor;
var
i: Integer;
begin
FProcessState := gtpsClassAncestor;
If FTypeInfoAncestor = nil then begin
FTypeInfoAncestor := TGDBType.CreateForExpression(FAncestor,
FCreationFlags*[gtcfClassIsPointer, gtcfFullTypeInfo, gtcfSkipTypeName] + [gtcfExprIsType]
);
AddSubType(FTypeInfoAncestor);
end;
if not FTypeInfoAncestor.IsFinished then
exit;
// add ancestor
if FTypeInfoAncestor.FFields <> nil then
for i := 0 to FTypeInfoAncestor.FFields.Count - 1 do
FFields.Add(FTypeInfoAncestor.FFields[i]);
Result := True;
end;
procedure FinishProcessClass;
begin
if (gtcfFullTypeInfo in FCreationFlags) and not (gtcfExprIsType in FCreationFlags) then
if not RequireRequests([gptrWhatisExpr]) then
exit;
// Handle Error in ptype^ as normal class
// May need a whatis, if aliased names are needed "type TFooAlias = type TFoo"
SetTypNameFromReq(gptrWhatisExpr, True);
DoClass;
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
then ProcessClassAncestor
else Result := True; // ====> DONE
end;
procedure ProcessClass;
var
t: TGDBTypeProcessRequest;
ResultList: TGDBMINameValueList;
s: String;
i: Integer;
begin
FProcessState := gtpsClass;
if (gtcfExprIsType in FCreationFlags) then begin
SetTypNameFromReq(gptrPTypeExpr, True);
DoClass;
if (gtcfFullTypeInfo in FCreationFlags) and (FAncestor <> '')
then ProcessClassAncestor
else Result := True; // ====> DONE
exit;
end;
if saRefParam in FAttributes
then t := gptrPTypeExprDeDeRef // &Class (var param; dwarf)
else t := gptrPTypeExprDeRef; // Class
if not RequireRequests([gptrPTypeExpr, t])
then exit;
if IsReqError(t)
then debugln('Failed "ptype expr^[^]" request for class expression');
if (not IsReqError(t)) and (ptprfPointer in FReqResults[t].Result.Flags)
then begin
ProcessClassPointer;
exit;
end
else begin
if (gtcfAutoCastClass in FCreationFlags) then begin
if not RequireRequests([gptrInstanceClassName]) then
exit;
if not IsReqError(gptrInstanceClassName) then begin
ResultList := TGDBMINameValueList.Create(FReqResults[gptrInstanceClassName].Result.GdbDescription);
s := ParseGDBString(ResultList.Values['value']);
ResultList.Free;
if s <> ''
then i := ord(s[1])
else i := 1;
if i <= length(s)-1 then begin
FAutoTypeCastName := copy(s, 2, i);
RequireRequests([gptrPtypeCustomAutoCast], FAutoTypeCastName);
FProcessState := gtpsClassAutoCast;
exit;
end;
// continue without type cast
end;
end;
FinishProcessClass;
end;
end;
procedure ProcessClassAutoCast;
var
s: String;
begin
if IsReqError(gptrPtypeCustomAutoCast) or
(not(FReqResults[gptrPtypeCustomAutoCast].Result.Kind = ptprkClass)) or
(LowerCase(FAutoTypeCastName) = LowerCase(PCLenToString(FReqResults[gptrPTypeExpr].Result.BaseName))) // don't typecast to itself
then begin
FinishProcessClass; // normal class finish
exit;
end;
s := FAutoTypeCastName + '(' + FExpression + ')';
if not RequireRequests([gptrPtypeCustomAutoCast2], s)
then exit;
if FHasAutoTypeCastFix
then s := '^' + s;
if IsReqError(gptrPtypeCustomAutoCast2) and (not FHasAutoTypeCastFix)
then begin
s := '^' + s;
FHasAutoTypeCastFix := True;
exclude(FProccesReuestsMade, gptrPtypeCustomAutoCast2);
RequireRequests([gptrPtypeCustomAutoCast2], FExpression);
exit;
end;
if IsReqError(gptrPtypeCustomAutoCast2) or
not(FReqResults[gptrPtypeCustomAutoCast2].Result.Kind = ptprkClass)
then begin
FinishProcessClass; // normal class finish
exit;
end;
FExpression := s;
FReqResults[gptrPTypeExpr] := FReqResults[gptrPtypeCustomAutoCast2];
exclude(FProccesReuestsMade, gptrWhatisExpr);
FinishProcessClass;
end;
{%endregion * Class * }
{%region * Array * }
procedure ProcessArray;
var
PTypeResult: TGDBPTypeResult;
begin
FProcessState := gtpsArray;
PTypeResult := FReqResults[gptrPTypeExpr].Result;
// In DWARF, some Dynamic Array, are pointer to there base type
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
if (not IsReqError(gptrPTypeExprDeRef)) then
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result;
// This implies it is an internal pointer
if (ptprfDynArray in PTypeResult.Flags)
then include(FAttributes, saInternalPointer);
end;
if (PTypeResult.Flags * [ptprfDynArray, ptprfPointer] = [ptprfDynArray, ptprfPointer])
then include(FAttributes, saInternalPointer);
if (saInternalPointer in FAttributes) then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
end;
if (saInternalPointer in FAttributes) and (not IsReqError(gptrPTypeExprDeRef)) then
PTypeResult := FReqResults[gptrPTypeExprDeRef].Result
else
PTypeResult := FReqResults[gptrPTypeExpr].Result;
if ptprfPointer in PTypeResult.Flags then begin
ProcessSimplePointer;
exit;
end;
FKind := skSimple;
if (ptprfDynArray in PTypeResult.Flags)
then include(FAttributes, saDynArray)
else include(FAttributes, saArray);
if not(gtcfSkipTypeName in FCreationFlags) then begin
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True);
end;
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
Result := True;
// ====> DONE
end;
{%endregion * Array * }
{%region * Simple * }
procedure ProcessSimplePointer;
begin
FProcessState := gtpsSimplePointer;
// there may be multiply levels of pointer, get the name of this pointer
if not RequireRequests([gptrPTypeExpr, gptrWhatisExpr])
then exit;
FKind := skPointer;
if not IsReqError(gptrWhatisExpr) and (FReqResults[gptrWhatisExpr].Result.Kind = ptprkSimple)
then begin
// Whatis result is ok
if (ptprfParamByRef in FReqResults[gptrWhatisExpr].Result.Flags) then
include(FAttributes, saRefParam);
SetTypNameFromReq(gptrWhatisExpr);
end
else begin
// Whatis result failed
SetTypNameFromReq(gptrPTypeExpr);
end;
Result := True;
// ====> DONE
end;
{%endregion * Simple * }
{%region * EvaluateExpression * }
procedure EvaluateExpression;
procedure ParseFromResult(AGdbDesc, AField: String);
var
ResultList: TGDBMINameValueList;
begin
ResultList := TGDBMINameValueList.Create(AGdbDesc);
FExprEvaluatedAsText := ResultList.Values[AField];
FHasExprEvaluatedAsText := True;
//FTextValue := DeleteEscapeChars(FTextValue);
ResultList.Free;
end;
procedure ParseFromResultForStrFixed(AGdbDesc, AField: String);
var
ResultList: TGDBMINameValueList;
begin
ResultList := TGDBMINameValueList.Create(AGdbDesc);
FStringExprEvaluatedAsText := ResultList.Values[AField];
FHasStringExprEvaluatedAsText := True;
//FTextValue := DeleteEscapeChars(FTextValue);
ResultList.Free;
end;
begin
FProcessState := gtpsEvalExpr;
if not(gtcfExprEvaluate in FCreationFlags) then begin
Result := True;
exit;
end;
if FExprEvaluateFormat <> wdfDefault then begin;
Result := True;
exit;
end;
// TODO: stringFixed need to know about:
// - ProcessInitFixTypeCast
// - AutoTypeCast
if (saInternalPointer in FAttributes) then begin
if not RequireRequests([gptrEvalExprDeRef]) then exit;
if not IsReqError(gptrEvalExprDeRef, False) then begin
ParseFromResult(FReqResults[gptrEvalExprDeRef].Result.GdbDescription, 'value');
if (gtcfExprEvalStrFixed in FCreationFlags) and
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
then begin
if not RequireRequests([gptrEvalExprDeRef2], FParsedExpression.TextStrFixed) then exit;
ParseFromResultForStrFixed(FReqResults[gptrEvalExprDeRef2].Result.GdbDescription, 'value');
end;
Result := True;
exit;
end;
end;
if (saRefParam in FAttributes) then begin
if not RequireRequests([gptrEvalExprCast]) then exit;
if not IsReqError(gptrEvalExprCast, False) then begin
ParseFromResult(FReqResults[gptrEvalExprCast].Result.GdbDescription, 'value');
if (gtcfExprEvalStrFixed in FCreationFlags) and
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
then begin
if not RequireRequests([gptrEvalExprCast2], FParsedExpression.TextStrFixed) then exit;
ParseFromResultForStrFixed(FReqResults[gptrEvalExprCast2].Result.GdbDescription, 'value');
end;
Result := True;
exit;
end;
end;
if not RequireRequests([gptrEvalExpr]) then exit;
if not IsReqError(gptrEvalExpr, False) then begin
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'value');
if (gtcfExprEvalStrFixed in FCreationFlags) and
(FParsedExpression <> nil) and FParsedExpression.MayNeedStringFix
then begin
if not RequireRequests([gptrEvalExpr2], FParsedExpression.TextStrFixed) then exit;
ParseFromResultForStrFixed(FReqResults[gptrEvalExpr2].Result.GdbDescription, 'value');
end;
Result := True;
exit;
end;
// TODO: set Validity = error
ParseFromResult(FReqResults[gptrEvalExpr].Result.GdbDescription, 'msg');
Result := True;
end;
{%endregion * EvaluateExpression * }
procedure ProcessInitialSimple;
var
i, j: Integer;
PTypeResult: TGDBPTypeResult;
begin
FProcessState := gtpsInitialSimple;
(* Will get gptrWhatisExpr later, it may fail, if expression is a typecast and needs ^ prefix *)
//if (gtcfFullTypeInfo in FCreationFlags)
//and not (gtcfExprIsType in FCreationFlags)
//then wi := [gptrWhatisExpr]
//else wi := [];
if not RequireRequests([gptrPTypeExpr]) //+wi)
then exit;
if IsReqError(gptrPTypeExpr) then begin
// maybe a typecast
if not FHasTypeCastFix then begin
j := length(FExpression);
i := 1;
while (i < j) and (FExpression[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) do inc(i);
if (i <= j) and (i > 1) and (FExpression[i] = '(')
then begin
RequireRequests([gptrPtypeCustomFixCast], copy(FExpression, 1, i-1));
FProcessState := gtpsInitFixTypeCast;
exit;
end;
end;
FEvalError := True;
exit;
end;
PTypeResult := FReqResults[gptrPTypeExpr].Result;
if (ptprfParamByRef in PTypeResult.Flags) then
include(FAttributes, saRefParam);
// In DWARF, some Dynamic Array, are pointer to there base type
if (ptprfPointer in PTypeResult.Flags) and (PTypeResult.Kind =ptprkSimple)
then begin
if not RequireRequests([gptrPTypeExprDeRef])
then exit;
if (not IsReqError(gptrPTypeExprDeRef)) and
(FReqResults[gptrPTypeExprDeRef].Result.Kind = ptprkArray)
then begin
ProcessArray;
exit;
end;
end;
case PTypeResult.Kind of
//ptprkError: ;
//ptprkSimple: ;
ptprkClass: begin
ProcessClass;
exit;
end;
//ptprkRecord: ;
//ptprkEnum: ;
//ptprkSet: ;
ptprkArray: begin
ProcessArray;
exit;
end;
//ptprkProcedure: ;
//ptprkFunction: ;
end;
if (ptprfPointer in PTypeResult.Flags)
and ( (PTypeResult.Kind in [ptprkSimple, ptprkRecord, ptprkEnum, ptprkSet])
or ( (gtcfClassIsPointer in FCreationFlags) and
(PTypeResult.Kind in [ptprkProcedure, ptprkFunction]) )
)
then begin
ProcessSimplePointer;
exit;
end;
if (ptprfParamByRef in PTypeResult.Flags)
and not (PTypeResult.Kind in [ptprkError])
then begin
// could be a pointer // need ptype of whatis
if not RequireRequests([gptrWhatisExpr])
then exit;
if (FReqResults[gptrWhatisExpr].Result.BaseName.Len > 0)
then begin
if not RequireRequests([gptrPTypeOfWhatis])
then exit;
if (not IsReqError(gptrPTypeOfWhatis, False))
and (ptprfPointer in FReqResults[gptrPTypeOfWhatis].Result.Flags) then begin
// pointer
FKind := skPointer;
SetTypNameFromReq(gptrWhatisExpr);
Result := True;
// ====> DONE
exit;
end;
end;
end;
case PTypeResult.Kind of
ptprkError: begin
// could be empty pointer @ArgProcedure
Result := True; // nothing to be done, keep simple type, no name
end;
ptprkSimple: begin
// may only need whatis, if current name isn't usable?
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True);
FKind := skSimple;
Result := True;
// ====> DONE
end;
ptprkClass: begin
Assert(False, 'GDBTypeInfo Class: Should be handled before');
ProcessClass;
end;
ptprkRecord: begin
SetTypNameFromReq(gptrWhatisExpr, True);
DoRecord;
Result := True;
// ====> DONE
end;
ptprkEnum: begin
SetTypNameFromReq(gptrWhatisExpr, True);
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
DoEnum;
Result := True;
// ====> DONE
end;
ptprkSet: begin
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True);
// TODO: resolve enum-name (set of SomeEnum) if mode-full ?
FTypeDeclaration := ClearAmpersand(PCLenToString(PTypeResult.Declaration));
i := pos('set of = ', FTypeDeclaration);
if i > 0 then delete(FTypeDeclaration, i+7, 3);
DoSet;
Result := True;
// ====> DONE
end;
ptprkArray: begin
Assert(False, 'GDBTypeInfo Array: Should be handled before');
ProcessArray;
end;
ptprkProcedure: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in PTypeResult.Flags)
then begin
ProcessSimplePointer;
exit;
end;
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True, 'procedure');
DoProcedure;
Result := True;
// ====> DONE
end;
ptprkFunction: begin
// under stabs, procedure/function are always pointer // pointer to proc/func return empty type
if (gtcfClassIsPointer in FCreationFlags) // Dwarf
and (ptprfPointer in PTypeResult.Flags)
then begin
ProcessSimplePointer;
exit;
end;
if not RequireRequests([gptrWhatisExpr])
then exit;
SetTypNameFromReq(gptrWhatisExpr, True, 'function');
DoFunction;
Result := True;
// ====> DONE
end;
end;
end;
procedure ProcessInitial;
begin
if FExpression = '' then begin;
ProcessInitialSimple;
exit;
end;
if FParsedExpression = nil
then FParsedExpression := TGDBExpression.Create(FExpression);
// Does not set FLastEvalRequest, so there can be no MergeSubProcessRequests
if FParsedExpression.NeedValidation(FEvalRequest)
then exit;
FExpression := FParsedExpression.Text;
ProcessInitialSimple;
end;
procedure ProcessInitFixTypeCast;
begin
// Some GDB can not process: "TFoo(SomeFoo).Bar"
// Because TFoo Is actually ^TFoo, therefore they need "^TFoo(SomeFoo).Bar"
if FHasTypeCastFix or IsReqError(gptrPtypeCustomFixCast) or
not(FReqResults[gptrPtypeCustomFixCast].Result.Kind = ptprkClass)
then begin
FEvalError := True;
exit;
end;
FHasTypeCastFix := True;
FExpression := '^' + FExpression;
// Redo the ptype
exclude(FProccesReuestsMade, gptrPTypeExpr);
ProcessInitialSimple;
end;
procedure MergeSubProcessRequests;
var
SubType: TGDBType;
begin
SubType := FFirstProcessingSubType;
while SubType <> nil do begin
if (FEvalRequest = nil)
then FEvalRequest := SubType.FEvalRequest
else FLastEvalRequest^.Next := SubType.FEvalRequest;;
FLastEvalRequest := SubType.FLastEvalRequest;
SubType := SubType.FNextProcessingSubType;
end;
end;
function ProcessSubProcessRequests: Boolean;
var
SubType, PrevSubType: TGDBType;
begin
Result := False;
PrevSubType := nil;
SubType := FFirstProcessingSubType;
Result := SubType = nil;
while SubType <> nil do begin
if SubType.ProcessExpression then begin
Result := True;
if PrevSubType = nil
then FFirstProcessingSubType := SubType.FNextProcessingSubType
else PrevSubType.FNextProcessingSubType := SubType.FNextProcessingSubType;
end;
PrevSubType := SubType;
SubType := SubType.FNextProcessingSubType;
end;
end;
var
OldProcessState: TGDBTypeProcessState;
OldReqMade: TGDBTypeProcessRequests;
{$IFDEF DBGMI_TYPE_INFO}
s: string;
{$ENDIF}
begin
Result := False;
FEvalRequest := nil;
FLastEvalRequest := nil;
Lines := nil;
{$IFDEF DBGMI_TYPE_INFO}
WriteStr(s, FProcessState);
DebugLnEnter(['>>Enter: TGDBType.ProcessExpression: state = ', s, ' Expression="', FExpression, '"']);
try
{$ENDIF}
if FFirstProcessingSubType <> nil then begin
if not ProcessSubProcessRequests then begin
MergeSubProcessRequests;
exit;
end;
end;
OldProcessState := FProcessState;
OldReqMade := FProccesReuestsMade;
case FProcessState of
gtpsInitial: ProcessInitial;
gtpsInitialSimple: ProcessInitialSimple;
gtpsInitFixTypeCast: ProcessInitFixTypeCast;
gtpsSimplePointer: ProcessSimplePointer;
gtpsClass: ProcessClass;
gtpsClassAutoCast: ProcessClassAutoCast;
gtpsClassPointer: ProcessClassPointer;
gtpsClassAncestor: ProcessClassAncestor;
gtpsArray: ProcessArray;
gtpsEvalExpr: EvaluateExpression;
end;
FreeAndNil(Lines);
if Result and not(FProcessState = gtpsEvalExpr)
then begin
Result := False;
EvaluateExpression;
end;
if Result
then FProcessState := gtpsFinished;
if FFirstProcessingSubType <> nil then
MergeSubProcessRequests
else
if (FProcessState = OldProcessState) and (FProccesReuestsMade = OldReqMade)
and (not Result) and (FEvalRequest = nil)
then begin
debugln('ERROR: detected state loop in ProcessExpression');
Result := True;
end;
{$IFDEF DBGMI_TYPE_INFO}
finally
WriteStr(s, FProcessState);
DebugLnExit(['<<Exit: TGDBType.ProcessExpression: state = ', s, ' Result=', dbgs(Result),
' Kind=', dbgs(Kind), ' Attr=', dbgs(Attributes), ' Typename="', TypeName, '" InternTpName="', FInternalTypeName,'"']);
end;
{$ENDIF}
end;
{ TGDBPTypes }
constructor TGDBTypes.CreateFromCSV(AValues: String);
var
GDBType: TGDBType;
begin
Create;
while AValues <> '' do
begin
GDBType := TGDBType.Create(skSimple, GetPart([], [', '], AValues));
FList.Add(GDBType);
{if Length(AValues) >= 2 then} Delete(AValues, 1, 2);
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink