mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-01 03:03:43 +02:00
2919 lines
92 KiB
ObjectPascal
2919 lines
92 KiB
ObjectPascal
{
|
|
---------------------------------------------------------------------------
|
|
FpPascalParser.pas - Native Freepascal debugger - Parse pascal expressions
|
|
---------------------------------------------------------------------------
|
|
|
|
***************************************************************************
|
|
* *
|
|
* 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., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
|
|
* *
|
|
***************************************************************************
|
|
}
|
|
unit FpPascalParser;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, sysutils, math, DbgIntfBaseTypes, FpDbgInfo, FpdMemoryTools, FpErrorMessages,
|
|
LazLoggerBase, LazClasses;
|
|
|
|
type
|
|
|
|
TFpPascalExpressionPart = class;
|
|
TFpPascalExpressionPartContainer = class;
|
|
TFpPascalExpressionPartWithPrecedence = class;
|
|
TFpPascalExpressionPartBracket = class;
|
|
TFpPascalExpressionPartOperator = class;
|
|
|
|
TFpPascalExpressionPartClass = class of TFpPascalExpressionPart;
|
|
TFpPascalExpressionPartBracketClass = class of TFpPascalExpressionPartBracket;
|
|
|
|
TSeparatorType = (ppstComma);
|
|
|
|
{ TFpPascalExpression }
|
|
|
|
TFpPascalExpression = class
|
|
private
|
|
FError: TFpError;
|
|
FContext: TFpDbgInfoContext;
|
|
FFixPCharIndexAccess: Boolean;
|
|
FHasPCharIndexAccess: Boolean;
|
|
FTextExpression: String;
|
|
FExpressionPart: TFpPascalExpressionPart;
|
|
FValid: Boolean;
|
|
function GetResultValue: TFpDbgValue;
|
|
function GetValid: Boolean;
|
|
procedure Parse;
|
|
procedure SetError(AMsg: String); // deprecated;
|
|
procedure SetError(AnErrorCode: TFpErrorCode; AData: array of const);
|
|
function PosFromPChar(APChar: PChar): Integer;
|
|
protected
|
|
function GetDbgSymbolForIdentifier({%H-}AnIdent: String): TFpDbgValue;
|
|
property ExpressionPart: TFpPascalExpressionPart read FExpressionPart;
|
|
property Context: TFpDbgInfoContext read FContext;
|
|
public
|
|
constructor Create(ATextExpression: String; AContext: TFpDbgInfoContext);
|
|
destructor Destroy; override;
|
|
function DebugDump(AWithResults: Boolean = False): String;
|
|
procedure ResetEvaluation;
|
|
property Error: TFpError read FError;
|
|
property Valid: Boolean read GetValid;
|
|
// Set by GetResultValue
|
|
property HasPCharIndexAccess: Boolean read FHasPCharIndexAccess;
|
|
// handle pchar as string (adjust index)
|
|
property FixPCharIndexAccess: Boolean read FFixPCharIndexAccess write FFixPCharIndexAccess;
|
|
// ResultValue
|
|
// - May be a type, if expression is a type
|
|
// - Only valid, as long as the expression is not destroyed
|
|
property ResultValue: TFpDbgValue read GetResultValue;
|
|
end;
|
|
|
|
|
|
{ TFpPascalExpressionPart }
|
|
|
|
TFpPascalExpressionPart = class
|
|
private
|
|
FEndChar: PChar;
|
|
FParent: TFpPascalExpressionPartContainer;
|
|
FStartChar: PChar;
|
|
FExpression: TFpPascalExpression;
|
|
FResultValue: TFpDbgValue;
|
|
FResultValDone: Boolean;
|
|
function GetResultValue: TFpDbgValue;
|
|
function GetSurroundingOpenBracket: TFpPascalExpressionPartBracket;
|
|
function GetTopParent: TFpPascalExpressionPart;
|
|
procedure SetEndChar(AValue: PChar);
|
|
procedure SetParent(AValue: TFpPascalExpressionPartContainer);
|
|
procedure SetStartChar(AValue: PChar);
|
|
procedure SetError(AMsg: String = ''); // deprecated;
|
|
procedure SetError(APart: TFpPascalExpressionPart; AMsg: String = ''); // deprecated;
|
|
procedure SetError(AnErrorCode: TFpErrorCode; AData: array of const);
|
|
protected
|
|
function DebugText(AIndent: String; {%H-}AWithResults: Boolean): String; virtual; // Self desc only
|
|
function DebugDump(AIndent: String; AWithResults: Boolean): String; virtual;
|
|
protected
|
|
procedure Init; virtual;
|
|
function DoGetIsTypeCast: Boolean; virtual; deprecated;
|
|
function DoGetResultValue: TFpDbgValue; virtual;
|
|
procedure ResetEvaluation;
|
|
|
|
Procedure ReplaceInParent(AReplacement: TFpPascalExpressionPart);
|
|
procedure DoHandleEndOfExpression; virtual;
|
|
|
|
function IsValidNextPart(APart: TFpPascalExpressionPart): Boolean; virtual;
|
|
function IsValidAfterPart({%H-}APrevPart: TFpPascalExpressionPart): Boolean; virtual;
|
|
function MaybeHandlePrevPart({%H-}APrevPart: TFpPascalExpressionPart;
|
|
var {%H-}AResult: TFpPascalExpressionPart): Boolean; virtual;
|
|
// HasPrecedence: an operator with follows precedence rules: the last operand can be taken by the next operator
|
|
function HasPrecedence: Boolean; virtual;
|
|
function FindLeftSideOperandByPrecedence({%H-}AnOperator: TFpPascalExpressionPartWithPrecedence):
|
|
TFpPascalExpressionPart; virtual;
|
|
function CanHaveOperatorAsNext: Boolean; virtual; // True
|
|
function HandleSeparator(ASeparatorType: TSeparatorType): Boolean; virtual; // False
|
|
property Expression: TFpPascalExpression read FExpression;
|
|
public
|
|
constructor Create(AExpression: TFpPascalExpression; AStartChar: PChar; AnEndChar: PChar = nil);
|
|
destructor Destroy; override;
|
|
function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; virtual;
|
|
procedure HandleEndOfExpression; virtual;
|
|
|
|
function GetText(AMaxLen: Integer=0): String;
|
|
property StartChar: PChar read FStartChar write SetStartChar;
|
|
property EndChar: PChar read FEndChar write SetEndChar;
|
|
property Parent: TFpPascalExpressionPartContainer read FParent write SetParent;
|
|
property TopParent: TFpPascalExpressionPart read GetTopParent; // or self
|
|
property SurroundingBracket: TFpPascalExpressionPartBracket read GetSurroundingOpenBracket; // incl self
|
|
property ResultValue: TFpDbgValue read GetResultValue;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartContainer }
|
|
|
|
TFpPascalExpressionPartContainer = class(TFpPascalExpressionPart)
|
|
private
|
|
FList: TList;
|
|
function GetCount: Integer;
|
|
function GetItems(AIndex: Integer): TFpPascalExpressionPart;
|
|
function GetLastItem: TFpPascalExpressionPart;
|
|
procedure SetItems(AIndex: Integer; AValue: TFpPascalExpressionPart);
|
|
procedure SetLastItem(AValue: TFpPascalExpressionPart);
|
|
protected
|
|
procedure Init; override;
|
|
function DebugDump(AIndent: String; AWithResults: Boolean): String; override;
|
|
public
|
|
destructor Destroy; override;
|
|
function Add(APart: TFpPascalExpressionPart): Integer;
|
|
function IndexOf(APart: TFpPascalExpressionPart): Integer;
|
|
procedure Clear;
|
|
property Count: Integer read GetCount;
|
|
property Items[AIndex: Integer]: TFpPascalExpressionPart read GetItems write SetItems;
|
|
property LastItem: TFpPascalExpressionPart read GetLastItem write SetLastItem;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartIdentifier }
|
|
|
|
TFpPascalExpressionPartIdentifier = class(TFpPascalExpressionPartContainer)
|
|
protected
|
|
function DoGetIsTypeCast: Boolean; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
TFpPascalExpressionPartConstant = class(TFpPascalExpressionPartContainer)
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartConstantNumber }
|
|
|
|
TFpPascalExpressionPartConstantNumber = class(TFpPascalExpressionPartConstant)
|
|
protected
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartConstantNumberFloat }
|
|
|
|
TFpPascalExpressionPartConstantNumberFloat = class(TFpPascalExpressionPartConstantNumber)
|
|
protected
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
TFpPascalExpressionPartConstantText = class(TFpPascalExpressionPartConstant)
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartWithPrecedence }
|
|
|
|
TFpPascalExpressionPartWithPrecedence = class(TFpPascalExpressionPartContainer)
|
|
protected
|
|
FPrecedence: Integer;
|
|
function HasPrecedence: Boolean; override;
|
|
public
|
|
property Precedence: Integer read FPrecedence;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracket }
|
|
|
|
TFpPascalExpressionPartBracket = class(TFpPascalExpressionPartWithPrecedence)
|
|
// some, but not all bracket expr have precedence
|
|
private
|
|
FIsClosed: boolean;
|
|
FIsClosing: boolean;
|
|
FAfterComma: Integer;
|
|
function GetAfterComma: Boolean;
|
|
protected
|
|
procedure Init; override;
|
|
function HasPrecedence: Boolean; override;
|
|
procedure DoHandleEndOfExpression; override;
|
|
function CanHaveOperatorAsNext: Boolean; override;
|
|
function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; virtual;
|
|
procedure SetAfterCommaFlag;
|
|
property AfterComma: Boolean read GetAfterComma;
|
|
public
|
|
procedure CloseBracket;
|
|
function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
procedure HandleEndOfExpression; override;
|
|
property IsClosed: boolean read FIsClosed;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartRoundBracket }
|
|
|
|
TFpPascalExpressionPartRoundBracket = class(TFpPascalExpressionPartBracket)
|
|
protected
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketSubExpression }
|
|
|
|
TFpPascalExpressionPartBracketSubExpression = class(TFpPascalExpressionPartRoundBracket)
|
|
protected
|
|
function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketArgumentList }
|
|
|
|
TFpPascalExpressionPartBracketArgumentList = class(TFpPascalExpressionPartRoundBracket)
|
|
// function arguments or type cast // this acts a operator: first element is the function/type
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
function DoGetIsTypeCast: Boolean; override;
|
|
function IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean; override;
|
|
function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
function MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean; override;
|
|
function HandleSeparator(ASeparatorType: TSeparatorType): Boolean; override;
|
|
end;
|
|
|
|
|
|
{ TFpPascalExpressionPartSquareBracket }
|
|
|
|
TFpPascalExpressionPartSquareBracket = class(TFpPascalExpressionPartBracket)
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketSet }
|
|
|
|
TFpPascalExpressionPartBracketSet = class(TFpPascalExpressionPartSquareBracket)
|
|
// a in [x, y, z]
|
|
protected
|
|
function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
function HandleSeparator(ASeparatorType: TSeparatorType): Boolean; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketIndex }
|
|
|
|
TFpPascalExpressionPartBracketIndex = class(TFpPascalExpressionPartSquareBracket)
|
|
// array[1]
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
function IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean; override;
|
|
function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
function MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean; override;
|
|
procedure DoHandleEndOfExpression; override;
|
|
function HandleSeparator(ASeparatorType: TSeparatorType): Boolean; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperator }
|
|
|
|
TFpPascalExpressionPartOperator = class(TFpPascalExpressionPartWithPrecedence)
|
|
protected
|
|
function DebugText(AIndent: String; AWithResults: Boolean): String; override;
|
|
function CanHaveOperatorAsNext: Boolean; override;
|
|
function FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence):
|
|
TFpPascalExpressionPart; override;
|
|
function HasAllOperands: Boolean; virtual; abstract;
|
|
function MaybeAddLeftOperand(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
procedure DoHandleEndOfExpression; override;
|
|
function HandleSeparator(ASeparatorType: TSeparatorType): Boolean; override;
|
|
public
|
|
function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartUnaryOperator }
|
|
|
|
TFpPascalExpressionPartUnaryOperator = class(TFpPascalExpressionPartOperator)
|
|
protected
|
|
function HasAllOperands: Boolean; override;
|
|
public
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBinaryOperator }
|
|
|
|
TFpPascalExpressionPartBinaryOperator = class(TFpPascalExpressionPartOperator)
|
|
protected
|
|
function HasAllOperands: Boolean; override;
|
|
function IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean; override;
|
|
public
|
|
function MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorAddressOf }
|
|
|
|
TFpPascalExpressionPartOperatorAddressOf = class(TFpPascalExpressionPartUnaryOperator) // @
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMakeRef }
|
|
|
|
TFpPascalExpressionPartOperatorMakeRef = class(TFpPascalExpressionPartUnaryOperator) // ^TTYpe
|
|
protected
|
|
procedure Init; override;
|
|
function IsValidNextPart(APart: TFpPascalExpressionPart): Boolean; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
function DoGetIsTypeCast: Boolean; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorDeRef }
|
|
|
|
TFpPascalExpressionPartOperatorDeRef = class(TFpPascalExpressionPartUnaryOperator) // ptrval^
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
function MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean; override;
|
|
function FindLeftSideOperandByPrecedence({%H-}AnOperator: TFpPascalExpressionPartWithPrecedence):
|
|
TFpPascalExpressionPart;
|
|
override;
|
|
// IsValidAfterPart: same as binary op
|
|
function IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorUnaryPlusMinus }
|
|
|
|
TFpPascalExpressionPartOperatorUnaryPlusMinus = class(TFpPascalExpressionPartUnaryOperator) // + -
|
|
// Unary + -
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorPlusMinus }
|
|
|
|
TFpPascalExpressionPartOperatorPlusMinus = class(TFpPascalExpressionPartBinaryOperator) // + -
|
|
// Binary + -
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMulDiv }
|
|
|
|
TFpPascalExpressionPartOperatorMulDiv = class(TFpPascalExpressionPartBinaryOperator) // * /
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorCompare }
|
|
|
|
TFpPascalExpressionPartOperatorCompare = class(TFpPascalExpressionPartBinaryOperator) // = < > <> ><
|
|
protected
|
|
procedure Init; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMemberOf }
|
|
|
|
TFpPascalExpressionPartOperatorMemberOf = class(TFpPascalExpressionPartBinaryOperator) // struct.member
|
|
protected
|
|
procedure Init; override;
|
|
function IsValidNextPart(APart: TFpPascalExpressionPart): Boolean; override;
|
|
function DoGetResultValue: TFpDbgValue; override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
const
|
|
// 1 highest
|
|
PRECEDENCE_MEMBER_OF = 1; // foo.bar
|
|
PRECEDENCE_MAKE_REF = 1; // ^TFoo
|
|
PRECEDENCE_ARG_LIST = 2; // foo() / TFoo()
|
|
PRECEDENCE_ARRAY_IDX = 2; // foo[1]
|
|
PRECEDENCE_DEREF = 5; // a^ // Precedence acts only to the left side
|
|
PRECEDENCE_ADRESS_OF = 6; // @a
|
|
//PRECEDENCE_POWER = 10; // ** (power) must be stronger than unary -
|
|
PRECEDENCE_UNARY_SIGN = 11; // -a
|
|
PRECEDENCE_MUL_DIV = 12; // a * b
|
|
PRECEDENCE_PLUS_MINUS = 13; // a + b
|
|
PRECEDENCE_COMPARE = 20; // a <> b // a=b
|
|
|
|
type
|
|
|
|
{%region DebugSymbol }
|
|
|
|
{ TPasParserSymbolPointer
|
|
used by TFpPasParserValueMakeReftype.GetDbgSymbol
|
|
}
|
|
|
|
TPasParserSymbolPointer = class(TFpDbgSymbol)
|
|
private
|
|
FPointerLevels: Integer;
|
|
FPointedTo: TFpDbgSymbol;
|
|
FContext: TFpDbgInfoContext;
|
|
protected
|
|
// NameNeeded // "^TPointedTo"
|
|
procedure TypeInfoNeeded; override;
|
|
public
|
|
constructor Create(const APointedTo: TFpDbgSymbol; AContext: TFpDbgInfoContext; APointerLevels: Integer);
|
|
constructor Create(const APointedTo: TFpDbgSymbol; AContext: TFpDbgInfoContext);
|
|
destructor Destroy; override;
|
|
function TypeCastValue(AValue: TFpDbgValue): TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TPasParserSymbolArrayDeIndex }
|
|
|
|
TPasParserSymbolArrayDeIndex = class(TDbgSymbolForwarder) // 1 index level off
|
|
private
|
|
FArray: TFpDbgSymbol;
|
|
protected
|
|
//procedure ForwardToSymbolNeeded; override;
|
|
function GetMemberCount: Integer; override;
|
|
function GetMember(AIndex: Int64): TFpDbgSymbol; override;
|
|
public
|
|
constructor Create(const AnArray: TFpDbgSymbol);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{%endregion DebugSymbol }
|
|
|
|
{%region DebugSymbolValue }
|
|
|
|
{ TFpPasParserValue }
|
|
|
|
TFpPasParserValue = class(TFpDbgValue)
|
|
private
|
|
FContext: TFpDbgInfoContext;
|
|
protected
|
|
function DebugText(AIndent: String): String; virtual;
|
|
public
|
|
constructor Create(AContext: TFpDbgInfoContext);
|
|
property Context: TFpDbgInfoContext read FContext;
|
|
end;
|
|
|
|
{ TFpPasParserValueCastToPointer
|
|
used by TPasParserSymbolPointer.TypeCastValue (which is used by TFpPasParserValueMakeReftype.GetDbgSymbol)
|
|
}
|
|
|
|
TFpPasParserValueCastToPointer = class(TFpPasParserValue)
|
|
private
|
|
FValue: TFpDbgValue;
|
|
FTypeSymbol: TFpDbgSymbol;
|
|
FLastMember: TFpDbgValue;
|
|
protected
|
|
function DebugText(AIndent: String): String; override;
|
|
protected
|
|
function GetKind: TDbgSymbolKind; override;
|
|
function GetFieldFlags: TFpDbgValueFieldFlags; override;
|
|
function GetTypeInfo: TFpDbgSymbol; override;
|
|
function GetAsCardinal: QWord; override;
|
|
function GetDataAddress: TFpDbgMemLocation; override;
|
|
function GetMember(AIndex: Int64): TFpDbgValue; override;
|
|
public
|
|
constructor Create(AValue: TFpDbgValue; ATypeInfo: TFpDbgSymbol; AContext: TFpDbgInfoContext);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TFpPasParserValueMakeReftype }
|
|
|
|
TFpPasParserValueMakeReftype = class(TFpPasParserValue)
|
|
private
|
|
FSourceTypeSymbol, FTypeSymbol: TFpDbgSymbol;
|
|
FRefLevel: Integer;
|
|
protected
|
|
function DebugText(AIndent: String): String; override;
|
|
protected
|
|
function GetDbgSymbol: TFpDbgSymbol; override; // returns a TPasParserSymbolPointer
|
|
public
|
|
constructor Create(ATypeInfo: TFpDbgSymbol; AContext: TFpDbgInfoContext);
|
|
destructor Destroy; override;
|
|
procedure IncRefLevel;
|
|
function GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue; override;
|
|
end;
|
|
|
|
{ TFpPasParserValueDerefPointer
|
|
Used as address source in typecast
|
|
}
|
|
|
|
TFpPasParserValueDerefPointer = class(TFpPasParserValue)
|
|
private
|
|
FValue: TFpDbgValue;
|
|
FAddressOffset: Int64; // Add to address
|
|
FCardinal: QWord; // todo: TFpDbgMemLocation ?
|
|
FCardinalRead: Boolean;
|
|
protected
|
|
function DebugText(AIndent: String): String; override;
|
|
protected
|
|
function GetFieldFlags: TFpDbgValueFieldFlags; override;
|
|
function GetAddress: TFpDbgMemLocation; override;
|
|
function GetSize: Integer; override;
|
|
function GetAsCardinal: QWord; override; // reads men
|
|
function GetTypeInfo: TFpDbgSymbol; override; // TODO: Cardinal? Why? // TODO: does not handle AOffset
|
|
public
|
|
constructor Create(AValue: TFpDbgValue; AContext: TFpDbgInfoContext);
|
|
constructor Create(AValue: TFpDbgValue; AContext: TFpDbgInfoContext; AOffset: Int64);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TFpPasParserValueAddressOf }
|
|
|
|
TFpPasParserValueAddressOf = class(TFpPasParserValue)
|
|
private
|
|
FValue: TFpDbgValue;
|
|
FTypeInfo: TFpDbgSymbol;
|
|
FLastMember: TFpDbgValue;
|
|
function GetPointedToValue: TFpDbgValue;
|
|
protected
|
|
function DebugText(AIndent: String): String; override;
|
|
protected
|
|
function GetKind: TDbgSymbolKind; override;
|
|
function GetFieldFlags: TFpDbgValueFieldFlags; override;
|
|
function GetAsInteger: Int64; override;
|
|
function GetAsCardinal: QWord; override;
|
|
function GetTypeInfo: TFpDbgSymbol; override;
|
|
function GetDataAddress: TFpDbgMemLocation; override;
|
|
function GetMember(AIndex: Int64): TFpDbgValue; override;
|
|
public
|
|
constructor Create(AValue: TFpDbgValue; AContext: TFpDbgInfoContext);
|
|
destructor Destroy; override;
|
|
property PointedToValue: TFpDbgValue read GetPointedToValue;
|
|
end;
|
|
|
|
{%endregion DebugSymbolValue }
|
|
|
|
function DbgsResultValue(AVal: TFpDbgValue; AIndent: String): String;
|
|
begin
|
|
if (AVal <> nil) and (AVal is TFpPasParserValue) then
|
|
Result := LineEnding + TFpPasParserValue(AVal).DebugText(AIndent)
|
|
else
|
|
if AVal <> nil then
|
|
Result := DbgSName(AVal) + ' DbsSym='+DbgSName(AVal.DbgSymbol)+' Type='+DbgSName(AVal.TypeInfo)
|
|
else
|
|
Result := DbgSName(AVal);
|
|
end;
|
|
|
|
function DbgsSymbol(AVal: TFpDbgSymbol; {%H-}AIndent: String): String;
|
|
begin
|
|
Result := DbgSName(AVal);
|
|
end;
|
|
|
|
function TFpPasParserValue.DebugText(AIndent: String): String;
|
|
begin
|
|
Result := AIndent + DbgSName(Self) + ' DbsSym='+DbgSName(DbgSymbol)+' Type='+DbgSName(TypeInfo) + LineEnding;
|
|
end;
|
|
|
|
constructor TFpPasParserValue.Create(AContext: TFpDbgInfoContext);
|
|
begin
|
|
FContext := AContext;
|
|
inherited Create;
|
|
end;
|
|
|
|
{ TPasParserSymbolValueCastToPointer }
|
|
|
|
function TFpPasParserValueCastToPointer.DebugText(AIndent: String): String;
|
|
begin
|
|
Result := inherited DebugText(AIndent)
|
|
+ AIndent + '-Value= ' + DbgsResultValue(FValue, AIndent + ' ') + LineEnding
|
|
+ AIndent + '-Symbol = ' + DbgsSymbol(FTypeSymbol, AIndent + ' ') + LineEnding;
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetKind: TDbgSymbolKind;
|
|
begin
|
|
Result := skPointer;
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetFieldFlags: TFpDbgValueFieldFlags;
|
|
begin
|
|
if (FValue.FieldFlags * [svfAddress, svfCardinal] <> [])
|
|
then
|
|
Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress]
|
|
else
|
|
Result := [];
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetTypeInfo: TFpDbgSymbol;
|
|
begin
|
|
Result := FTypeSymbol;
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetAsCardinal: QWord;
|
|
var
|
|
f: TFpDbgValueFieldFlags;
|
|
begin
|
|
Result := 0;
|
|
f := FValue.FieldFlags;
|
|
if svfCardinal in f then
|
|
Result := FValue.AsCardinal
|
|
else
|
|
if svfAddress in f then begin
|
|
if not FContext.MemManager.ReadUnsignedInt(FValue.Address, FContext.SizeOfAddress, Result) then
|
|
Result := 0;
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetDataAddress: TFpDbgMemLocation;
|
|
begin
|
|
Result := TargetLoc(TDbgPtr(AsCardinal));
|
|
end;
|
|
|
|
function TFpPasParserValueCastToPointer.GetMember(AIndex: Int64): TFpDbgValue;
|
|
var
|
|
ti: TFpDbgSymbol;
|
|
addr: TFpDbgMemLocation;
|
|
Tmp: TFpDbgValueConstAddress;
|
|
begin
|
|
Result := nil;
|
|
|
|
ti := FTypeSymbol.TypeInfo;
|
|
addr := DataAddress;
|
|
if not IsTargetAddr(addr) then begin
|
|
//LastError := CreateError(fpErrAnyError, ['Internal dereference error']);
|
|
exit;
|
|
end;
|
|
{$PUSH}{$R-}{$Q-} // TODO: check overflow
|
|
if ti <> nil then
|
|
AIndex := AIndex * ti.Size;
|
|
addr.Address := addr.Address + AIndex;
|
|
{$POP}
|
|
|
|
Tmp := TFpDbgValueConstAddress.Create(addr);
|
|
if ti <> nil then begin
|
|
Result := ti.TypeCastValue(Tmp);
|
|
Tmp.ReleaseReference;
|
|
end
|
|
else
|
|
Result := Tmp;
|
|
FLastMember := Result;
|
|
end;
|
|
|
|
constructor TFpPasParserValueCastToPointer.Create(AValue: TFpDbgValue;
|
|
ATypeInfo: TFpDbgSymbol; AContext: TFpDbgInfoContext);
|
|
begin
|
|
inherited Create(AContext);
|
|
FValue := AValue;
|
|
FValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserSymbolValueCastToPointer'){$ENDIF};
|
|
FTypeSymbol := ATypeInfo;
|
|
FTypeSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeSymbol, 'TPasParserSymbolValueCastToPointer'){$ENDIF};
|
|
Assert((FTypeSymbol=nil) or (FTypeSymbol.Kind = skPointer), 'TPasParserSymbolValueCastToPointer.Create');
|
|
end;
|
|
|
|
destructor TFpPasParserValueCastToPointer.Destroy;
|
|
begin
|
|
FLastMember.ReleaseReference;
|
|
FValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserSymbolValueCastToPointer'){$ENDIF};
|
|
FTypeSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeSymbol, 'TPasParserSymbolValueCastToPointer'){$ENDIF};
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TPasParserSymbolValueMakeReftype }
|
|
|
|
function TFpPasParserValueMakeReftype.DebugText(AIndent: String): String;
|
|
begin
|
|
Result := inherited DebugText(AIndent)
|
|
+ AIndent + '-RefLevel = ' + dbgs(FRefLevel) + LineEnding
|
|
+ AIndent + '-SourceSymbol = ' + DbgsSymbol(FSourceTypeSymbol, AIndent + ' ') + LineEnding
|
|
+ AIndent + '-Symbol = ' + DbgsSymbol(FTypeSymbol, AIndent + ' ') + LineEnding;
|
|
end;
|
|
|
|
function TFpPasParserValueMakeReftype.GetDbgSymbol: TFpDbgSymbol;
|
|
begin
|
|
if FTypeSymbol = nil then begin
|
|
FTypeSymbol := TPasParserSymbolPointer.Create(FSourceTypeSymbol, FContext, FRefLevel);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}FTypeSymbol.DbgRenameReference(@FSourceTypeSymbol, 'TPasParserSymbolValueMakeReftype'){$ENDIF};
|
|
end;
|
|
Result := FTypeSymbol;
|
|
end;
|
|
|
|
constructor TFpPasParserValueMakeReftype.Create(ATypeInfo: TFpDbgSymbol;
|
|
AContext: TFpDbgInfoContext);
|
|
begin
|
|
inherited Create(AContext);
|
|
FSourceTypeSymbol := ATypeInfo;
|
|
FSourceTypeSymbol.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSourceTypeSymbol, 'TPasParserSymbolValueMakeReftype'){$ENDIF};
|
|
FRefLevel := 1;
|
|
end;
|
|
|
|
destructor TFpPasParserValueMakeReftype.Destroy;
|
|
begin
|
|
FSourceTypeSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSourceTypeSymbol, 'TPasParserSymbolValueMakeReftype'){$ENDIF};
|
|
FTypeSymbol.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FSourceTypeSymbol, 'TPasParserSymbolValueMakeReftype'){$ENDIF};
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TFpPasParserValueMakeReftype.IncRefLevel;
|
|
begin
|
|
inc(FRefLevel);
|
|
end;
|
|
|
|
function TFpPasParserValueMakeReftype.GetTypeCastedValue(ADataVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := DbgSymbol.TypeCastValue(ADataVal);
|
|
end;
|
|
|
|
|
|
{ TPasParserDerefPointerSymbolValue }
|
|
|
|
function TFpPasParserValueDerefPointer.DebugText(AIndent: String): String;
|
|
begin
|
|
Result := inherited DebugText(AIndent)
|
|
+ AIndent + '-Value= ' + DbgsResultValue(FValue, AIndent + ' ') + LineEnding;
|
|
end;
|
|
|
|
function TFpPasParserValueDerefPointer.GetFieldFlags: TFpDbgValueFieldFlags;
|
|
var
|
|
t: TFpDbgSymbol;
|
|
begin
|
|
// MUST *NOT* have ordinal
|
|
Result := [svfAddress];
|
|
t := FValue.TypeInfo;
|
|
if t <> nil then t := t.TypeInfo;
|
|
if t <> nil then
|
|
if t.Kind = skPointer then begin
|
|
//Result := Result + [svfSizeOfPointer];
|
|
Result := Result + [svfSizeOfPointer, svfCardinal, svfOrdinal]; // TODO: svfCardinal ???
|
|
end
|
|
else
|
|
Result := Result + [svfSize];
|
|
end;
|
|
|
|
function TFpPasParserValueDerefPointer.GetAddress: TFpDbgMemLocation;
|
|
begin
|
|
Result := FValue.DataAddress;
|
|
if FAddressOffset <> 0 then begin
|
|
assert(IsTargetAddr(Result ), 'TFpPasParserValueDerefPointer.GetAddress: TargetLoc(Result)');
|
|
if IsTargetAddr(Result) then
|
|
Result.Address := Result.Address + FAddressOffset
|
|
else
|
|
Result := InvalidLoc;
|
|
end;
|
|
end;
|
|
|
|
function TFpPasParserValueDerefPointer.GetSize: Integer;
|
|
var
|
|
t: TFpDbgSymbol;
|
|
begin
|
|
t := FValue.TypeInfo;
|
|
if t <> nil then t := t.TypeInfo;
|
|
if t <> nil then
|
|
Result := t.Size
|
|
else
|
|
Result := inherited GetSize;
|
|
end;
|
|
|
|
function TFpPasParserValueDerefPointer.GetAsCardinal: QWord;
|
|
var
|
|
m: TFpDbgMemManager;
|
|
Addr: TFpDbgMemLocation;
|
|
Ctx: TFpDbgInfoContext;
|
|
AddrSize: Integer;
|
|
begin
|
|
Result := FCardinal;
|
|
if FCardinalRead then exit;
|
|
|
|
Ctx := Context;
|
|
if Ctx = nil then exit;
|
|
AddrSize := Ctx.SizeOfAddress;
|
|
if (AddrSize <= 0) or (AddrSize > SizeOf(FCardinal)) then exit;
|
|
m := Ctx.MemManager;
|
|
if m = nil then exit;
|
|
|
|
FCardinal := 0;
|
|
FCardinalRead := True;
|
|
Addr := GetAddress;
|
|
if not IsReadableLoc(Addr) then exit;
|
|
FCardinal := LocToAddrOrNil(m.ReadAddress(Addr, Ctx.SizeOfAddress));
|
|
|
|
Result := FCardinal;
|
|
end;
|
|
|
|
function TFpPasParserValueDerefPointer.GetTypeInfo: TFpDbgSymbol;
|
|
var
|
|
t: TFpDbgSymbol;
|
|
begin
|
|
t := FValue.TypeInfo;
|
|
if t <> nil then t := t.TypeInfo;
|
|
if t <> nil then
|
|
Result := t
|
|
else
|
|
Result := inherited GetTypeInfo;
|
|
end;
|
|
|
|
constructor TFpPasParserValueDerefPointer.Create(AValue: TFpDbgValue;
|
|
AContext: TFpDbgInfoContext);
|
|
begin
|
|
Create(AValue, AContext, 0);
|
|
end;
|
|
|
|
constructor TFpPasParserValueDerefPointer.Create(AValue: TFpDbgValue;
|
|
AContext: TFpDbgInfoContext; AOffset: Int64);
|
|
begin
|
|
inherited Create(AContext);
|
|
FValue := AValue;
|
|
FValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserDerefPointerSymbolValue'){$ENDIF};
|
|
FAddressOffset := AOffset;
|
|
end;
|
|
|
|
destructor TFpPasParserValueDerefPointer.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserDerefPointerSymbolValue'){$ENDIF};
|
|
end;
|
|
|
|
{ TPasParserAddressOfSymbolValue }
|
|
|
|
function TFpPasParserValueAddressOf.GetPointedToValue: TFpDbgValue;
|
|
begin
|
|
Result := FValue;
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.DebugText(AIndent: String): String;
|
|
begin
|
|
Result := inherited DebugText(AIndent)
|
|
+ AIndent + '-Value= ' + DbgsResultValue(FValue, AIndent + ' ') + LineEnding
|
|
+ AIndent + '-Symbol = ' + DbgsSymbol(FTypeInfo, AIndent + ' ') + LineEnding;
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetKind: TDbgSymbolKind;
|
|
begin
|
|
Result := skPointer;
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetFieldFlags: TFpDbgValueFieldFlags;
|
|
begin
|
|
Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress];
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetAsInteger: Int64;
|
|
begin
|
|
Result := Int64(LocToAddrOrNil(FValue.Address));
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetAsCardinal: QWord;
|
|
begin
|
|
Result := QWord(LocToAddrOrNil(FValue.Address));
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetTypeInfo: TFpDbgSymbol;
|
|
begin
|
|
Result := FTypeInfo;
|
|
if Result <> nil then
|
|
exit;
|
|
if FValue.TypeInfo = nil then
|
|
exit;
|
|
|
|
FTypeInfo := TPasParserSymbolPointer.Create(FValue.TypeInfo, FContext);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}FTypeInfo.DbgRenameReference(@FTypeInfo, 'TPasParserAddressOfSymbolValue');{$ENDIF}
|
|
Result := FTypeInfo;
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetDataAddress: TFpDbgMemLocation;
|
|
begin
|
|
Result := FValue.Address;
|
|
end;
|
|
|
|
function TFpPasParserValueAddressOf.GetMember(AIndex: Int64): TFpDbgValue;
|
|
var
|
|
ti: TFpDbgSymbol;
|
|
addr: TFpDbgMemLocation;
|
|
Tmp: TFpDbgValueConstAddress;
|
|
begin
|
|
if (AIndex = 0) or (FValue = nil) then begin
|
|
Result := FValue;
|
|
exit;
|
|
end;
|
|
|
|
Result := nil;
|
|
ti := FValue.TypeInfo;
|
|
addr := FValue.Address;
|
|
if not IsTargetAddr(addr) then begin
|
|
//LastError := CreateError(fpErrAnyError, ['Internal dereference error']);
|
|
exit;
|
|
end;
|
|
{$PUSH}{$R-}{$Q-} // TODO: check overflow
|
|
if ti <> nil then
|
|
AIndex := AIndex * ti.Size;
|
|
addr.Address := addr.Address + AIndex;
|
|
{$POP}
|
|
|
|
Tmp := TFpDbgValueConstAddress.Create(addr);
|
|
if ti <> nil then begin
|
|
Result := ti.TypeCastValue(Tmp);
|
|
Tmp.ReleaseReference;
|
|
end
|
|
else
|
|
Result := Tmp;
|
|
FLastMember := Result;
|
|
end;
|
|
|
|
constructor TFpPasParserValueAddressOf.Create(AValue: TFpDbgValue;
|
|
AContext: TFpDbgInfoContext);
|
|
begin
|
|
inherited Create(AContext);
|
|
FValue := AValue;
|
|
FValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserAddressOfSymbolValue'){$ENDIF};
|
|
end;
|
|
|
|
destructor TFpPasParserValueAddressOf.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FLastMember.ReleaseReference;
|
|
FValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserAddressOfSymbolValue'){$ENDIF};
|
|
FTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeInfo, 'TPasParserAddressOfSymbolValue'){$ENDIF};
|
|
end;
|
|
|
|
{ TPasParserSymbolArrayDeIndex }
|
|
|
|
function TPasParserSymbolArrayDeIndex.GetMemberCount: Integer;
|
|
begin
|
|
Result := (inherited GetMemberCount) - 1;
|
|
end;
|
|
|
|
function TPasParserSymbolArrayDeIndex.GetMember(AIndex: Int64): TFpDbgSymbol;
|
|
begin
|
|
Result := inherited GetMember(AIndex + 1);
|
|
end;
|
|
|
|
constructor TPasParserSymbolArrayDeIndex.Create(const AnArray: TFpDbgSymbol);
|
|
begin
|
|
FArray := AnArray;
|
|
FArray.AddReference;
|
|
inherited Create('');
|
|
SetKind(skArray);
|
|
SetForwardToSymbol(FArray);
|
|
end;
|
|
|
|
destructor TPasParserSymbolArrayDeIndex.Destroy;
|
|
begin
|
|
ReleaseRefAndNil(FArray);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TPasParserSymbolPointer }
|
|
|
|
procedure TPasParserSymbolPointer.TypeInfoNeeded;
|
|
var
|
|
t: TPasParserSymbolPointer;
|
|
begin
|
|
assert(FPointerLevels > 1, 'TPasParserSymbolPointer.TypeInfoNeeded: FPointerLevels > 1');
|
|
t := TPasParserSymbolPointer.Create(FPointedTo, FContext, FPointerLevels-1);
|
|
SetTypeInfo(t);
|
|
t.ReleaseReference;
|
|
end;
|
|
|
|
constructor TPasParserSymbolPointer.Create(const APointedTo: TFpDbgSymbol;
|
|
AContext: TFpDbgInfoContext; APointerLevels: Integer);
|
|
begin
|
|
inherited Create('');
|
|
FContext := AContext;
|
|
FPointerLevels := APointerLevels;
|
|
FPointedTo := APointedTo;
|
|
FPointedTo.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(FPointedTo, 'TPasParserSymbolPointer'){$ENDIF};
|
|
if APointerLevels = 1 then
|
|
SetTypeInfo(APointedTo);
|
|
SetKind(skPointer);
|
|
SetSymbolType(stType);
|
|
end;
|
|
|
|
constructor TPasParserSymbolPointer.Create(const APointedTo: TFpDbgSymbol;
|
|
AContext: TFpDbgInfoContext);
|
|
begin
|
|
Create(APointedTo, AContext, 1);
|
|
end;
|
|
|
|
destructor TPasParserSymbolPointer.Destroy;
|
|
begin
|
|
FPointedTo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(FPointedTo, 'TPasParserSymbolPointer'){$ENDIF};
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TPasParserSymbolPointer.TypeCastValue(AValue: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := TFpPasParserValueCastToPointer.Create(AValue, Self, FContext);
|
|
end;
|
|
|
|
|
|
{ TFpPascalExpressionPartBracketIndex }
|
|
|
|
procedure TFpPascalExpressionPartBracketIndex.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_ARRAY_IDX;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketIndex.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
TmpVal, TmpVal2, TmpIndex: TFpDbgValue;
|
|
i: Integer;
|
|
Offs: Int64;
|
|
ti: TFpDbgSymbol;
|
|
IsPChar: Boolean;
|
|
begin
|
|
Result := nil;
|
|
assert(Count >= 2, 'TFpPascalExpressionPartBracketIndex.DoGetResultValue: Count >= 2');
|
|
if Count < 2 then exit;
|
|
|
|
TmpVal := Items[0].ResultValue;
|
|
if TmpVal = nil then exit;
|
|
|
|
TmpVal.AddReference;
|
|
for i := 1 to Count - 1 do begin
|
|
TmpVal2 := nil;
|
|
TmpIndex := Items[i].ResultValue;
|
|
if TmpIndex = nil then begin
|
|
// error should be set by Items[i]
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end;
|
|
case TmpVal.Kind of
|
|
skArray: begin
|
|
if (svfInteger in TmpIndex.FieldFlags) then
|
|
TmpVal2 := TmpVal.Member[TmpIndex.AsInteger]
|
|
else
|
|
if (svfOrdinal in TmpIndex.FieldFlags) and
|
|
(TmpIndex.AsCardinal <= high(Int64))
|
|
then
|
|
TmpVal2 := TmpVal.Member[TmpIndex.AsCardinal]
|
|
else
|
|
begin
|
|
SetError('Can not calculate Index');
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end;
|
|
if TmpVal2 <> nil then TmpVal2.AddReference;
|
|
end; // Kind = skArray
|
|
skPointer: begin
|
|
if (svfInteger in TmpIndex.FieldFlags) then
|
|
Offs := TmpIndex.AsInteger
|
|
else
|
|
if (svfOrdinal in TmpIndex.FieldFlags) and (TmpIndex.AsCardinal <= high(Int64))
|
|
then
|
|
Offs := Int64(TmpIndex.AsCardinal)
|
|
else
|
|
begin
|
|
SetError('Can not calculate Index');
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end;
|
|
|
|
ti := TmpVal.TypeInfo;
|
|
if (ti <> nil) then ti := ti.TypeInfo;
|
|
IsPChar := (ti <> nil) and (ti.Kind in [skChar]) and (Offs > 0);
|
|
if IsPChar then FExpression.FHasPCharIndexAccess := True;
|
|
if IsPChar and FExpression.FixPCharIndexAccess then begin
|
|
// fix for string in dwarf 2
|
|
if Offs > 0 then
|
|
dec(Offs);
|
|
end;
|
|
|
|
TmpVal2 := TmpVal.Member[Offs];
|
|
if IsError(TmpVal.LastError) then
|
|
SetError('Error dereferencing'); // TODO: set correct error
|
|
if TmpVal2 <> nil then TmpVal2.AddReference;
|
|
end;
|
|
skString: begin
|
|
//TODO
|
|
SetError('Not implemented');
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
SetError(fpErrTypeHasNoIndex, [GetText]);
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
if TmpVal2 = nil then begin
|
|
SetError('Internal Error, attempting to read array element');
|
|
TmpVal.ReleaseReference;
|
|
exit;
|
|
end;
|
|
TmpVal.ReleaseReference;
|
|
TmpVal := TmpVal2;
|
|
end;
|
|
|
|
Result := TmpVal;
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketIndex.IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := inherited IsValidAfterPart(APrevPart);
|
|
Result := Result and APrevPart.CanHaveOperatorAsNext;
|
|
if (APrevPart.Parent <> nil) and (APrevPart.Parent.HasPrecedence) then
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketIndex.HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
if Count < 1 then begin // Todo a,b,c
|
|
SetError(APart, 'Internal error handling [] '+GetText+': '); // Missing the array on which this index works
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
if (Count > 1) and (not AfterComma) then begin
|
|
SetError(APart, 'Comma or closing "]" expected '+GetText+': ');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
if not IsValidNextPart(APart) then begin
|
|
SetError(APart, 'Invalid operand in [] '+GetText+': ');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Add(APart);
|
|
Result := APart;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketIndex.MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
var
|
|
ALeftSide: TFpPascalExpressionPart;
|
|
begin
|
|
//Result := MaybeAddLeftOperand(APrevPart, AResult);
|
|
|
|
Result := APrevPart.IsValidNextPart(Self);
|
|
if not Result then
|
|
exit;
|
|
|
|
AResult := Self;
|
|
if (Count > 0) // function/type already set
|
|
then begin
|
|
SetError(APrevPart, 'Parse error in () '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide := APrevPart.FindLeftSideOperandByPrecedence(Self);
|
|
if ALeftSide = nil then begin
|
|
SetError(Self, 'Internal parser error for operator '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide.ReplaceInParent(Self);
|
|
Add(ALeftSide);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracketIndex.DoHandleEndOfExpression;
|
|
begin
|
|
inherited DoHandleEndOfExpression;
|
|
if (Count < 2) then
|
|
SetError(fpErrPasParserMissingIndexExpression, [GetText]);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketIndex.HandleSeparator(ASeparatorType: TSeparatorType): Boolean;
|
|
begin
|
|
if (not (ASeparatorType = ppstComma)) or IsClosed then begin
|
|
Result := inherited HandleSeparator(ASeparatorType);
|
|
exit;
|
|
end;
|
|
|
|
Result := (Count > FAfterComma) and (Count > 1); // First element is name of array (in front of "[")
|
|
if Result then
|
|
SetAfterCommaFlag;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketSet }
|
|
|
|
function TFpPascalExpressionPartBracketSet.HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
if (Count > 0) and (not AfterComma) then begin
|
|
SetError('To many expressions'); // TODO comma
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Result := APart;
|
|
Add(APart);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketSet.HandleSeparator(ASeparatorType: TSeparatorType): Boolean;
|
|
begin
|
|
if (not (ASeparatorType = ppstComma)) or IsClosed then begin
|
|
Result := inherited HandleSeparator(ASeparatorType);
|
|
exit;
|
|
end;
|
|
|
|
Result := (Count > FAfterComma) and (Count > 0);
|
|
if Result then
|
|
SetAfterCommaFlag;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartWithPrecedence }
|
|
|
|
function TFpPascalExpressionPartWithPrecedence.HasPrecedence: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
|
|
{ TFpPascalExpressionPartBracketArgumentList }
|
|
|
|
procedure TFpPascalExpressionPartBracketArgumentList.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_ARG_LIST;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp, tmp2: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
|
|
if (Count = 0) then begin
|
|
SetError(fpErrPasParserInvalidExpression, []);
|
|
exit;
|
|
end;
|
|
|
|
tmp := Items[0].ResultValue;
|
|
if (tmp = nil) or (not Expression.Valid) then
|
|
exit;
|
|
|
|
if (Count = 2) then begin
|
|
//TODO if tmp is TFpPascalExpressionPartOperatorMakeRef then
|
|
// AVOID creating the TPasParserSymbolPointer by calling tmp.DbgSymbol
|
|
// it ran be created in TPasParserSymbolValueCastToPointer if needed.
|
|
if (tmp <> nil) and (tmp.DbgSymbol <> nil) and
|
|
(tmp.DbgSymbol.SymbolType = stType)
|
|
then begin
|
|
// This is a typecast
|
|
tmp2 := Items[1].ResultValue;
|
|
if tmp2 <> nil then
|
|
Result := tmp.GetTypeCastedValue(tmp2);
|
|
//Result := tmp.DbgSymbol.TypeCastValue(tmp2);
|
|
if Result <> nil then
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF};
|
|
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
// Must be function call
|
|
SetError('No support for calling functions');
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.DoGetIsTypeCast: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := inherited IsValidAfterPart(APrevPart);
|
|
Result := Result and APrevPart.CanHaveOperatorAsNext;
|
|
if (APrevPart.Parent <> nil) and (APrevPart.Parent.HasPrecedence) then
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
if Count < 1 then begin // Todo a,b,c
|
|
SetError(APart, 'Internal error handling () '+GetText+': '); // Missing the functionname on which this index works
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
if (Count > 1) and (not AfterComma) then begin // Todo a,b,c
|
|
SetError(APart, 'Comma or closing ")" expected: '+GetText+': ');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
if not IsValidNextPart(APart) then begin
|
|
SetError(APart, 'Invalid operand in () '+GetText+': ');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Add(APart);
|
|
Result := APart;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
var
|
|
ALeftSide: TFpPascalExpressionPart;
|
|
begin
|
|
//Result := MaybeAddLeftOperand(APrevPart, AResult);
|
|
|
|
Result := APrevPart.IsValidNextPart(Self);
|
|
if not Result then
|
|
exit;
|
|
|
|
AResult := Self;
|
|
if (Count > 0) // function/type already set
|
|
then begin
|
|
SetError(APrevPart, 'Parse error in () '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide := APrevPart.FindLeftSideOperandByPrecedence(Self);
|
|
if ALeftSide = nil then begin
|
|
SetError(Self, 'Internal parser error for operator '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide.ReplaceInParent(Self);
|
|
Add(ALeftSide);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketArgumentList.HandleSeparator(ASeparatorType: TSeparatorType): Boolean;
|
|
begin
|
|
if (not (ASeparatorType = ppstComma)) or IsClosed then begin
|
|
Result := inherited HandleSeparator(ASeparatorType);
|
|
exit;
|
|
end;
|
|
|
|
Result := (Count > FAfterComma) and (Count > 1); // First element is name of function (in front of "(")
|
|
if Result then
|
|
SetAfterCommaFlag;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracketSubExpression }
|
|
|
|
function TFpPascalExpressionPartBracketSubExpression.HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
if Count > 0 then begin
|
|
SetError('To many expressions');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Result := APart;
|
|
Add(APart);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracketSubExpression.DoGetResultValue: TFpDbgValue;
|
|
begin
|
|
if Count <> 1 then
|
|
Result := nil
|
|
else
|
|
Result := Items[0].ResultValue;
|
|
if Result <> nil then
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartIdentifier }
|
|
|
|
function TFpPascalExpressionPartIdentifier.DoGetIsTypeCast: Boolean;
|
|
begin
|
|
Result := (ResultValue <> nil) and (ResultValue.DbgSymbol <> nil) and (ResultValue.DbgSymbol.SymbolType = stType);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartIdentifier.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
s: String;
|
|
tmp: TFpDbgValueConstAddress;
|
|
begin
|
|
s := GetText;
|
|
Result := FExpression.GetDbgSymbolForIdentifier(s);
|
|
if Result = nil then begin
|
|
s := LowerCase(s);
|
|
if s = 'nil' then begin
|
|
tmp := TFpDbgValueConstAddress.Create(NilLoc);
|
|
Result := TFpPasParserValueAddressOf.Create(tmp, Expression.Context);
|
|
tmp.ReleaseReference;
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end
|
|
else
|
|
if s = 'true' then begin
|
|
Result := TFpDbgValueConstBool.Create(True);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end
|
|
else
|
|
if s = 'false' then begin
|
|
Result := TFpDbgValueConstBool.Create(False);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end
|
|
else begin
|
|
SetError(fpErrSymbolNotFound, [GetText]);
|
|
exit;
|
|
end;
|
|
end
|
|
|
|
else
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
function GetFirstToken(AText: PChar): String;
|
|
begin
|
|
Result := AText[0];
|
|
if AText^ in ['a'..'z', 'A'..'Z', '_', '0'..'9'] then begin
|
|
inc(AText);
|
|
while (AText^ in ['a'..'z', 'A'..'Z', '_', '0'..'9']) and (Length(Result) < 200) do begin
|
|
Result := Result + AText[0];
|
|
inc(AText);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
inc(AText);
|
|
while not (AText^ in [#0..#32, 'a'..'z', 'A'..'Z', '_', '0'..'9']) and (Length(Result) < 100) do begin
|
|
Result := Result + AText[0];
|
|
inc(AText);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartConstantNumber }
|
|
|
|
function TFpPascalExpressionPartConstantNumber.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
i: QWord;
|
|
e: word;
|
|
begin
|
|
Val(GetText, i, e);
|
|
if e <> 0 then begin
|
|
Result := nil;
|
|
SetError(fpErrInvalidNumber, [GetText]);
|
|
exit;
|
|
end;
|
|
|
|
if FStartChar^ in ['0'..'9'] then
|
|
Result := TFpDbgValueConstNumber.Create(i, False)
|
|
else
|
|
Result := TFpDbgValueConstNumber.Create(Int64(i), True); // hex,oct,bin values default to signed
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartConstantNumberFloat }
|
|
|
|
function TFpPascalExpressionPartConstantNumberFloat.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
f: Extended;
|
|
s: String;
|
|
begin
|
|
s := GetText;
|
|
if not TextToFloat(PChar(s), f) then begin
|
|
Result := nil;
|
|
SetError(fpErrInvalidNumber, [GetText]);
|
|
exit;
|
|
end;
|
|
|
|
Result := TFpDbgValueConstFloat.Create(f);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
{ TFpPascalExpression }
|
|
|
|
procedure TFpPascalExpression.Parse;
|
|
var
|
|
CurPtr, EndPtr, TokenEndPtr: PChar;
|
|
CurPart, NewPart: TFpPascalExpressionPart;
|
|
|
|
procedure AddPart(AClass: TFpPascalExpressionPartClass);
|
|
begin
|
|
NewPart := AClass.Create(Self, CurPtr, TokenEndPtr-1);
|
|
end;
|
|
|
|
procedure AddPlusMinus;
|
|
begin
|
|
if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext)
|
|
then AddPart(TFpPascalExpressionPartOperatorUnaryPlusMinus)
|
|
else AddPart(TFpPascalExpressionPartOperatorPlusMinus);
|
|
end;
|
|
|
|
procedure AddIdentifier;
|
|
begin
|
|
while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_', '0'..'9'] do
|
|
inc(TokenEndPtr);
|
|
// TODO: Check functions not, and, in, as, is ...
|
|
case TokenEndPtr - CurPtr of
|
|
3: case CurPtr^ of
|
|
'd', 'D':
|
|
if (CurPtr[1] in ['i', 'I']) and (CurPtr[2] in ['v', 'V']) then
|
|
NewPart := TFpPascalExpressionPartOperatorMulDiv.Create(Self, CurPtr, TokenEndPtr-1);
|
|
end;
|
|
end;
|
|
if NewPart = nil then
|
|
NewPart := TFpPascalExpressionPartIdentifier.Create(Self, CurPtr, TokenEndPtr-1);
|
|
end;
|
|
|
|
procedure HandleDot;
|
|
begin
|
|
while TokenEndPtr^ = '.' do
|
|
inc(TokenEndPtr);
|
|
case TokenEndPtr - CurPtr of
|
|
1: AddPart(TFpPascalExpressionPartOperatorMemberOf);
|
|
//2: ; // ".."
|
|
else SetError('Failed parsing ...');
|
|
end;
|
|
end;
|
|
|
|
procedure AddRefOperator;
|
|
begin
|
|
if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext)
|
|
then AddPart(TFpPascalExpressionPartOperatorMakeRef)
|
|
else AddPart(TFpPascalExpressionPartOperatorDeRef);
|
|
end;
|
|
|
|
procedure HandleRoundBracket;
|
|
begin
|
|
if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext)
|
|
then AddPart(TFpPascalExpressionPartBracketSubExpression)
|
|
else AddPart(TFpPascalExpressionPartBracketArgumentList);
|
|
end;
|
|
|
|
procedure HandleSqareBracket;
|
|
begin
|
|
if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext)
|
|
then AddPart(TFpPascalExpressionPartBracketSet)
|
|
else AddPart(TFpPascalExpressionPartBracketIndex);
|
|
end;
|
|
|
|
procedure CloseBracket(ABracketClass: TFpPascalExpressionPartBracketClass);
|
|
var
|
|
BracketPart: TFpPascalExpressionPartBracket;
|
|
begin
|
|
BracketPart := CurPart.SurroundingBracket;
|
|
if BracketPart = nil then begin
|
|
SetError('Closing bracket found without opening')
|
|
end
|
|
else
|
|
if not (BracketPart is ABracketClass) then begin
|
|
SetError('Mismatch bracket')
|
|
end
|
|
else begin
|
|
TFpPascalExpressionPartBracket(BracketPart).CloseBracket;
|
|
CurPart := BracketPart;
|
|
end;
|
|
end;
|
|
|
|
procedure AddConstNumber;
|
|
begin
|
|
case CurPtr^ of
|
|
'$': while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '0'..'9'] do inc(TokenEndPtr);
|
|
'&': while TokenEndPtr^ in ['0'..'7'] do inc(TokenEndPtr);
|
|
'%': while TokenEndPtr^ in ['0'..'1'] do inc(TokenEndPtr);
|
|
'0'..'9':
|
|
if (CurPtr^ = '0') and ((CurPtr + 1)^ in ['x', 'X']) and
|
|
((CurPtr + 2)^ in ['a'..'z', 'A'..'Z', '0'..'9'])
|
|
then begin
|
|
inc(TokenEndPtr, 2);
|
|
while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '0'..'9'] do inc(TokenEndPtr);
|
|
end
|
|
else begin
|
|
while TokenEndPtr^ in ['0'..'9'] do inc(TokenEndPtr);
|
|
// identify "2.", but not "[2..3]" // CurExpr.IsFloatAllowed
|
|
if (TokenEndPtr^ = DecimalSeparator) and (TokenEndPtr[1] <> '.') then begin
|
|
inc(TokenEndPtr);
|
|
while TokenEndPtr^ in ['0'..'9'] do inc(TokenEndPtr);
|
|
if TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_'] then
|
|
SetError(fpErrPasParserUnexpectedToken, [GetFirstToken(CurPtr), PosFromPChar(CurPtr)])
|
|
else
|
|
AddPart(TFpPascalExpressionPartConstantNumberFloat);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
if TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_'] then
|
|
SetError(fpErrPasParserUnexpectedToken, [GetFirstToken(CurPtr), PosFromPChar(CurPtr)])
|
|
else
|
|
AddPart(TFpPascalExpressionPartConstantNumber);
|
|
end;
|
|
|
|
procedure HandleCompare;
|
|
begin
|
|
if (CurPtr^ = '<') and (TokenEndPtr^ in ['>', '=']) then
|
|
inc(TokenEndPtr);
|
|
if (CurPtr^ = '>') and (TokenEndPtr^ in ['<', '=']) then
|
|
inc(TokenEndPtr);
|
|
AddPart(TFpPascalExpressionPartOperatorCompare);
|
|
end;
|
|
|
|
procedure HandleComma;
|
|
begin
|
|
if not CurPart.HandleSeparator(ppstComma) then
|
|
SetError(fpErrPasParserUnexpectedToken, [GetFirstToken(CurPtr), PosFromPChar(CurPtr)]);
|
|
end;
|
|
|
|
procedure AddConstChar;
|
|
begin
|
|
SetError(Format('Unexpected char ''%0:s'' at pos %1:d', [CurPtr^, PosFromPChar(CurPtr)])); // error
|
|
end;
|
|
|
|
begin
|
|
if FTextExpression = '' then
|
|
exit;
|
|
CurPtr := @FTextExpression[1];
|
|
EndPtr := CurPtr + length(FTextExpression);
|
|
CurPart := nil;
|
|
|
|
While (CurPtr < EndPtr) and FValid do begin
|
|
if CurPtr^ in [' ', #9, #10, #13] then begin
|
|
while (CurPtr^ in [' ', #9, #10, #13]) and (CurPtr < EndPtr) do
|
|
Inc(CurPtr);
|
|
continue;
|
|
end;
|
|
|
|
NewPart := nil;
|
|
TokenEndPtr := CurPtr + 1;
|
|
case CurPtr^ of
|
|
'@' : AddPart(TFpPascalExpressionPartOperatorAddressOf);
|
|
'^': AddRefOperator; // ^A may be #$01
|
|
'.': HandleDot;
|
|
'+', '-' : AddPlusMinus;
|
|
'*', '/' : AddPart(TFpPascalExpressionPartOperatorMulDiv);
|
|
'(': HandleRoundBracket;
|
|
')': CloseBracket(TFpPascalExpressionPartRoundBracket);
|
|
'[': HandleSqareBracket;
|
|
']': CloseBracket(TFpPascalExpressionPartSquareBracket);
|
|
',': HandleComma;
|
|
'=', '<',
|
|
'>': HandleCompare;//TFpPascalExpressionPartOperatorCompare
|
|
'''', '#': AddConstChar;
|
|
'0'..'9',
|
|
'$', '%', '&': AddConstNumber;
|
|
'a'..'z',
|
|
'A'..'Z', '_': AddIdentifier;
|
|
else begin
|
|
//SetError(fpErrPasParserUnexpectedToken, [GetFirstToken(CurPtr), PosFromPChar(CurPtr)])
|
|
SetError(Format('Unexpected token ''%0:s'' at pos %1:d', [CurPtr^, PosFromPChar(CurPtr)])); // error
|
|
break;
|
|
end;
|
|
end;
|
|
if not FValid then
|
|
break;
|
|
|
|
if CurPart = nil then
|
|
CurPart := NewPart
|
|
else
|
|
if NewPart <> nil then
|
|
CurPart := CurPart.HandleNextPart(NewPart);
|
|
|
|
CurPtr := TokenEndPtr;
|
|
end; // While CurPtr < EndPtr do begin
|
|
|
|
|
|
|
|
if Valid then begin
|
|
if CurPart <> nil then begin
|
|
CurPart.HandleEndOfExpression;
|
|
CurPart := CurPart.TopParent;
|
|
end
|
|
else
|
|
SetError('No Expression');
|
|
end
|
|
else
|
|
if CurPart <> nil then
|
|
CurPart := CurPart.TopParent;
|
|
|
|
FExpressionPart := CurPart;
|
|
end;
|
|
|
|
function TFpPascalExpression.GetResultValue: TFpDbgValue;
|
|
begin
|
|
if (FExpressionPart = nil) or (not Valid) then
|
|
Result := nil
|
|
else begin
|
|
Result := FExpressionPart.ResultValue;
|
|
if (Result = nil) and (not IsError(FError)) then
|
|
SetError(fpErrAnyError, ['Internal eval error']);
|
|
end;
|
|
end;
|
|
|
|
function TFpPascalExpression.GetValid: Boolean;
|
|
begin
|
|
Result := FValid and (not IsError(FError));
|
|
end;
|
|
|
|
procedure TFpPascalExpression.SetError(AMsg: String);
|
|
begin
|
|
if IsError(FError) then begin
|
|
DebugLn(['Skipping error ', AMsg]);
|
|
FValid := False;
|
|
exit;
|
|
end;
|
|
SetError(fpErrAnyError, [AMsg]);
|
|
DebugLn(['PARSER ERROR ', AMsg]);
|
|
end;
|
|
|
|
procedure TFpPascalExpression.SetError(AnErrorCode: TFpErrorCode; AData: array of const);
|
|
begin
|
|
FValid := False;
|
|
FError := ErrorHandler.CreateError(AnErrorCode, AData);
|
|
DebugLn(['Setting error ', ErrorHandler.ErrorAsString(FError)]);
|
|
end;
|
|
|
|
function TFpPascalExpression.PosFromPChar(APChar: PChar): Integer;
|
|
begin
|
|
Result := APChar - @FTextExpression[1] + 1;
|
|
end;
|
|
|
|
function TFpPascalExpression.GetDbgSymbolForIdentifier(AnIdent: String): TFpDbgValue;
|
|
begin
|
|
if FContext <> nil then
|
|
Result := FContext.FindSymbol(AnIdent)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
constructor TFpPascalExpression.Create(ATextExpression: String;
|
|
AContext: TFpDbgInfoContext);
|
|
begin
|
|
FContext := AContext;
|
|
FTextExpression := ATextExpression;
|
|
FError := NoError;
|
|
FValid := True;
|
|
Parse;
|
|
end;
|
|
|
|
destructor TFpPascalExpression.Destroy;
|
|
begin
|
|
FreeAndNil(FExpressionPart);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TFpPascalExpression.DebugDump(AWithResults: Boolean): String;
|
|
begin
|
|
Result := 'TFpPascalExpression: ' + FTextExpression + LineEnding +
|
|
'Valid: ' + dbgs(FValid) + ' Error: "' + dbgs(ErrorCode(FError)) + '"'+ LineEnding
|
|
;
|
|
if FExpressionPart <> nil then
|
|
Result := Result + FExpressionPart.DebugDump(' ', AWithResults);
|
|
if AWithResults and (ResultValue <> nil) then
|
|
if (ResultValue is TFpPasParserValue) then
|
|
Result := Result + 'ResultValue = ' + LineEnding + TFpPasParserValue(ResultValue).DebugText(' ')
|
|
else
|
|
Result := Result + 'ResultValue = ' + LineEnding + DbgSName(ResultValue) + LineEnding ;
|
|
end;
|
|
|
|
procedure TFpPascalExpression.ResetEvaluation;
|
|
begin
|
|
FExpressionPart.ResetEvaluation;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPart }
|
|
|
|
procedure TFpPascalExpressionPart.SetEndChar(AValue: PChar);
|
|
begin
|
|
if FEndChar = AValue then Exit;
|
|
FEndChar := AValue;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.GetTopParent: TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
while Result.Parent <> nil do
|
|
Result := Result.Parent;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.GetSurroundingOpenBracket: TFpPascalExpressionPartBracket;
|
|
var
|
|
tmp: TFpPascalExpressionPart;
|
|
begin
|
|
Result := nil;
|
|
tmp := Self;
|
|
while (tmp <> nil) and
|
|
( not(tmp is TFpPascalExpressionPartBracket) or ((tmp as TFpPascalExpressionPartBracket).IsClosed) )
|
|
do
|
|
tmp := tmp.Parent;
|
|
if tmp <> nil then
|
|
Result := TFpPascalExpressionPartBracket(tmp);
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.GetResultValue: TFpDbgValue;
|
|
begin
|
|
Result := FResultValue;
|
|
if FResultValDone then
|
|
exit;
|
|
FResultValue := DoGetResultValue;
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if FResultValue <> nil then FResultValue.DbgRenameReference(nil, 'DoGetResultValue', @FResultValue, 'DoGetResultValue');{$ENDIF}
|
|
FResultValDone := True;
|
|
Result := FResultValue;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.SetParent(AValue: TFpPascalExpressionPartContainer);
|
|
begin
|
|
if FParent = AValue then Exit;
|
|
FParent := AValue;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.SetStartChar(AValue: PChar);
|
|
begin
|
|
if FStartChar = AValue then Exit;
|
|
FStartChar := AValue;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.GetText(AMaxLen: Integer): String;
|
|
var
|
|
Len: Integer;
|
|
begin
|
|
if FEndChar <> nil
|
|
then Len := FEndChar - FStartChar + 1
|
|
else Len := min(AMaxLen, 10);
|
|
if (AMaxLen > 0) and (Len > AMaxLen) then
|
|
Len := AMaxLen;
|
|
Result := Copy(FStartChar, 1, Len);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.SetError(AMsg: String);
|
|
begin
|
|
if AMsg = '' then
|
|
AMsg := 'Invalid Expression';
|
|
FExpression.SetError(Format('%0:s at %1:d: "%2:s"', [AMsg, FExpression.PosFromPChar(FStartChar), GetText(20)]));
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.SetError(APart: TFpPascalExpressionPart; AMsg: String);
|
|
begin
|
|
if APart <> nil
|
|
then APart.SetError(AMsg)
|
|
else Self.SetError(AMsg);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.SetError(AnErrorCode: TFpErrorCode; AData: array of const);
|
|
begin
|
|
FExpression.SetError(AnErrorCode, AData);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.Init;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.DoGetIsTypeCast: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.DoGetResultValue: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.ResetEvaluation;
|
|
begin
|
|
FResultValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FResultValue, 'DoGetResultValue'){$ENDIF};
|
|
FResultValue := nil;
|
|
FResultValDone := False;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.ReplaceInParent(AReplacement: TFpPascalExpressionPart);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Parent = nil then exit;
|
|
i := Parent.IndexOf(Self);
|
|
Assert(i >= 0);
|
|
Parent.Items[i] := AReplacement;
|
|
Parent := nil;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.DoHandleEndOfExpression;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.IsValidNextPart(APart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := APart.IsValidAfterPart(Self);
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.HasPrecedence: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.CanHaveOperatorAsNext: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.HandleSeparator(ASeparatorType: TSeparatorType): Boolean;
|
|
begin
|
|
Result := (Parent <> nil) and Parent.HandleSeparator(ASeparatorType);
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.DebugText(AIndent: String; AWithResults: Boolean): String;
|
|
begin
|
|
Result := Format('%s%s at %d: "%s"',
|
|
[AIndent, ClassName, FExpression.PosFromPChar(FStartChar), GetText])
|
|
+ LineEnding;
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.DebugDump(AIndent: String; AWithResults: Boolean): String;
|
|
begin
|
|
Result := DebugText(AIndent, AWithResults);
|
|
if AWithResults and (FResultValue <> nil) then
|
|
if (FResultValue is TFpPasParserValue) then
|
|
Result := Result + TFpPasParserValue(FResultValue).DebugText(AIndent+' // ')
|
|
else
|
|
Result := Result + AIndent+' // FResultValue = ' + DbgSName(FResultValue) + LineEnding;
|
|
end;
|
|
|
|
constructor TFpPascalExpressionPart.Create(AExpression: TFpPascalExpression; AStartChar: PChar;
|
|
AnEndChar: PChar);
|
|
begin
|
|
FExpression := AExpression;
|
|
FStartChar := AStartChar;
|
|
FEndChar := AnEndChar;
|
|
//FResultTypeFlag := rtUnknown;
|
|
FResultValDone := False;
|
|
Init;
|
|
end;
|
|
|
|
destructor TFpPascalExpressionPart.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
//FResultType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultType'){$ENDIF};
|
|
FResultValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FResultValue, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
function TFpPascalExpressionPart.HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := APart;
|
|
if APart.MaybeHandlePrevPart(Self, Result) then
|
|
exit;
|
|
|
|
if Parent <> nil then begin
|
|
Result := Parent.HandleNextPart(APart);
|
|
exit;
|
|
end;
|
|
|
|
SetError(APart, 'Unexpected ');
|
|
APart.Free;
|
|
Result := Self;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPart.HandleEndOfExpression;
|
|
begin
|
|
DoHandleEndOfExpression;
|
|
if Parent <> nil then
|
|
Parent.HandleEndOfExpression;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartContainer }
|
|
|
|
function TFpPascalExpressionPartContainer.GetItems(AIndex: Integer): TFpPascalExpressionPart;
|
|
begin
|
|
Result := TFpPascalExpressionPart(FList[AIndex]);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartContainer.GetLastItem: TFpPascalExpressionPart;
|
|
begin
|
|
if Count > 0 then
|
|
Result := Items[Count - 1]
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartContainer.SetItems(AIndex: Integer;
|
|
AValue: TFpPascalExpressionPart);
|
|
begin
|
|
AValue.Parent := Self;
|
|
FList[AIndex] := AValue;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartContainer.SetLastItem(AValue: TFpPascalExpressionPart);
|
|
begin
|
|
assert(Count >0);
|
|
Items[Count-1] := AValue;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartContainer.Init;
|
|
begin
|
|
FList := TList.Create;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartContainer.DebugDump(AIndent: String;
|
|
AWithResults: Boolean): String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := inherited DebugDump(AIndent, AWithResults);
|
|
for i := 0 to Count - 1 do
|
|
Result := Result + Items[i].DebugDump(AIndent+' ', AWithResults);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartContainer.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
destructor TFpPascalExpressionPartContainer.Destroy;
|
|
begin
|
|
Clear;
|
|
FreeAndNil(FList);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartContainer.Add(APart: TFpPascalExpressionPart): Integer;
|
|
begin
|
|
APart.Parent := Self;
|
|
Result := FList.Add(APart);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartContainer.IndexOf(APart: TFpPascalExpressionPart): Integer;
|
|
begin
|
|
Result := Count - 1;
|
|
while (Result >= 0) and (Items[Result] <> APart) do
|
|
dec(Result);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartContainer.Clear;
|
|
begin
|
|
while Count > 0 do begin
|
|
Items[0].Free;
|
|
FList.Delete(0);
|
|
end;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBracket }
|
|
|
|
function TFpPascalExpressionPartBracket.GetAfterComma: Boolean;
|
|
begin
|
|
Result := (FAfterComma = Count);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracket.Init;
|
|
begin
|
|
inherited Init;
|
|
FIsClosed := False;
|
|
FIsClosing := False;
|
|
FAfterComma := -1;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracket.HasPrecedence: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracket.DoHandleEndOfExpression;
|
|
begin
|
|
if not IsClosed then begin
|
|
SetError('Bracket not closed');
|
|
exit;
|
|
end;
|
|
inherited DoHandleEndOfExpression;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracket.CanHaveOperatorAsNext: Boolean;
|
|
begin
|
|
Result := IsClosed;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracket.HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
APart.Free;
|
|
SetError('Error in ()');
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracket.SetAfterCommaFlag;
|
|
begin
|
|
FAfterComma := Count;
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracket.CloseBracket;
|
|
begin
|
|
if AfterComma then begin
|
|
SetError(fpErrPasParserMissingExprAfterComma, [GetText]);
|
|
exit;
|
|
end;
|
|
FIsClosing := True;
|
|
if LastItem <> nil then
|
|
LastItem.HandleEndOfExpression;
|
|
FIsClosing := False;
|
|
FIsClosed := True;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBracket.HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
if IsClosed then begin
|
|
Result := inherited HandleNextPart(APart);
|
|
exit;
|
|
end;
|
|
|
|
if not IsValidNextPart(APart) then begin
|
|
SetError(APart, 'Invalid operand in () '+GetText+': ');
|
|
Result := self;
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Result := HandleNextPartInBracket(APart);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartBracket.HandleEndOfExpression;
|
|
begin
|
|
if not FIsClosing then
|
|
inherited HandleEndOfExpression;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperator }
|
|
|
|
function TFpPascalExpressionPartOperator.DebugText(AIndent: String;
|
|
AWithResults: Boolean): String;
|
|
begin
|
|
Result := inherited DebugText(AIndent, AWithResults);
|
|
while Result[Length(Result)] in [#10, #13] do SetLength(Result, Length(Result)-1);
|
|
Result := Result + ' Precedence:' + dbgs(FPrecedence) +
|
|
LineEnding;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperator.CanHaveOperatorAsNext: Boolean;
|
|
begin
|
|
Result := HasAllOperands and LastItem.CanHaveOperatorAsNext;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperator.FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
|
|
if (not HasAllOperands) or (LastItem = nil) then begin
|
|
Result := nil;
|
|
exit
|
|
end;
|
|
|
|
// precedence: 1 = highest
|
|
if Precedence > AnOperator.Precedence then
|
|
Result := LastItem.FindLeftSideOperandByPrecedence(AnOperator);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperator.MaybeAddLeftOperand(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
var
|
|
ALeftSide: TFpPascalExpressionPart;
|
|
begin
|
|
Result := APrevPart.IsValidNextPart(Self);
|
|
if not Result then
|
|
exit;
|
|
|
|
AResult := Self;
|
|
if (Count > 0) or // Previous already set
|
|
(not APrevPart.CanHaveOperatorAsNext) // can not have 2 operators follow each other
|
|
then begin
|
|
SetError(APrevPart, 'Can not apply operator '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide := APrevPart.FindLeftSideOperandByPrecedence(Self);
|
|
if ALeftSide = nil then begin
|
|
SetError(Self, 'Internal parser error for operator '+GetText+': ');
|
|
APrevPart.Free;
|
|
exit;
|
|
end;
|
|
|
|
ALeftSide.ReplaceInParent(Self);
|
|
Add(ALeftSide);
|
|
end;
|
|
|
|
procedure TFpPascalExpressionPartOperator.DoHandleEndOfExpression;
|
|
begin
|
|
if not HasAllOperands then
|
|
SetError(Self, 'Not enough operands')
|
|
else
|
|
inherited DoHandleEndOfExpression;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperator.HandleSeparator(ASeparatorType: TSeparatorType): Boolean;
|
|
begin
|
|
Result := HasAllOperands and (inherited HandleSeparator(ASeparatorType));
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperator.HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
if HasAllOperands then begin
|
|
Result := inherited HandleNextPart(APart);
|
|
exit;
|
|
end;
|
|
if not IsValidNextPart(APart) then begin
|
|
SetError(APart, 'Not possible after Operator '+GetText+': ');
|
|
APart.Free;
|
|
exit;
|
|
end;
|
|
|
|
Add(APart);
|
|
Result := APart;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartUnaryOperator }
|
|
|
|
function TFpPascalExpressionPartUnaryOperator.HasAllOperands: Boolean;
|
|
begin
|
|
Result := Count = 1;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartBinaryOperator }
|
|
|
|
function TFpPascalExpressionPartBinaryOperator.HasAllOperands: Boolean;
|
|
begin
|
|
Result := Count = 2;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBinaryOperator.IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := inherited IsValidAfterPart(APrevPart);
|
|
if not Result then
|
|
exit;
|
|
|
|
Result := APrevPart.CanHaveOperatorAsNext;
|
|
|
|
// BinaryOperator...
|
|
// foo
|
|
// Identifier
|
|
// "Identifier" can hane a binary-op next. But it must be applied to the parent.
|
|
// So it is not valid here.
|
|
// If new operator has a higher precedence, it go down to the child again and replace it
|
|
if (APrevPart.Parent <> nil) and (APrevPart.Parent.HasPrecedence) then
|
|
Result := False;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartBinaryOperator.MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := MaybeAddLeftOperand(APrevPart, AResult);
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorAddressOf }
|
|
|
|
procedure TFpPascalExpressionPartOperatorAddressOf.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_ADRESS_OF;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorAddressOf.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 1 then exit;
|
|
|
|
tmp := Items[0].ResultValue;
|
|
if (tmp = nil) or not IsTargetAddr(tmp.Address) then
|
|
exit;
|
|
|
|
Result := TFpPasParserValueAddressOf.Create(tmp, Expression.Context);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMakeRef }
|
|
|
|
procedure TFpPascalExpressionPartOperatorMakeRef.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_MAKE_REF;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMakeRef.IsValidNextPart(APart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
if HasAllOperands then
|
|
Result := (inherited IsValidNextPart(APart))
|
|
else
|
|
Result := (inherited IsValidNextPart(APart)) and
|
|
( (APart is TFpPascalExpressionPartIdentifier) or
|
|
(APart is TFpPascalExpressionPartOperatorMakeRef)
|
|
);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMakeRef.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 1 then exit;
|
|
|
|
tmp := Items[0].ResultValue;
|
|
if tmp = nil then
|
|
exit;
|
|
if tmp is TFpPasParserValueMakeReftype then begin
|
|
TFpPasParserValueMakeReftype(tmp).IncRefLevel;
|
|
Result := tmp;
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
exit;
|
|
end;
|
|
|
|
if (tmp.DbgSymbol = nil) or (tmp.DbgSymbol.SymbolType <> stType) then
|
|
exit;
|
|
|
|
Result := TFpPasParserValueMakeReftype.Create(tmp.DbgSymbol, Expression.Context);
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF};
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMakeRef.DoGetIsTypeCast: Boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorDeRef }
|
|
|
|
procedure TFpPascalExpressionPartOperatorDeRef.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_DEREF;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorDeRef.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 1 then exit;
|
|
|
|
tmp := Items[0].ResultValue;
|
|
if tmp = nil then
|
|
exit;
|
|
|
|
if tmp is TFpPasParserValueAddressOf then begin // TODO: remove IF, handled in GetMember
|
|
Result := TFpPasParserValueAddressOf(tmp).PointedToValue;
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
end
|
|
else
|
|
if tmp.Kind = skPointer then begin
|
|
if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DataAddress)) and // TODO, what if Not readable addr
|
|
(tmp.TypeInfo <> nil) //and (tmp.TypeInfo.TypeInfo <> nil)
|
|
then begin
|
|
Result := tmp.Member[0];
|
|
if Result <> nil then
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
|
|
end;
|
|
end
|
|
//if tmp.Kind = skArray then // dynarray
|
|
else
|
|
begin
|
|
Result := nil;
|
|
SetError(fpErrCannotDereferenceType, [GetText]);
|
|
end;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorDeRef.MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart;
|
|
var AResult: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := MaybeAddLeftOperand(APrevPart, AResult);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorDeRef.FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence): TFpPascalExpressionPart;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorDeRef.IsValidAfterPart(APrevPart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := inherited IsValidAfterPart(APrevPart);
|
|
if not Result then
|
|
exit;
|
|
|
|
Result := APrevPart.CanHaveOperatorAsNext;
|
|
|
|
// BinaryOperator...
|
|
// foo
|
|
// Identifier
|
|
// "Identifier" can hane a binary-op next. But it must be applied to the parent.
|
|
// So it is not valid here.
|
|
// If new operator has a higher precedence, it go down to the child again and replace it
|
|
if (APrevPart.Parent <> nil) and (APrevPart.Parent is TFpPascalExpressionPartOperator) then
|
|
Result := False;
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorUnaryPlusMinus }
|
|
|
|
procedure TFpPascalExpressionPartOperatorUnaryPlusMinus.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_UNARY_SIGN;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorUnaryPlusMinus.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp1: TFpDbgValue;
|
|
IsAdd: Boolean;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 1 then exit;
|
|
assert((GetText = '+') or (GetText = '-'), 'TFpPascalExpressionPartOperatorUnaryPlusMinus.DoGetResultValue: (GetText = +) or (GetText = -)');
|
|
|
|
tmp1 := Items[0].ResultValue;
|
|
IsAdd := GetText = '+';
|
|
if (tmp1 = nil) then exit;
|
|
|
|
{$PUSH}{$R-}{$Q-}
|
|
if IsAdd then begin
|
|
case tmp1.Kind of
|
|
skPointer: ;
|
|
skInteger: Result := tmp1;
|
|
skCardinal: Result := tmp1;
|
|
end;
|
|
end
|
|
else begin
|
|
case tmp1.Kind of
|
|
skPointer: ;
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(-tmp1.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(-tmp1.AsCardinal, True);
|
|
end;
|
|
end;
|
|
{$POP}
|
|
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorPlusMinus }
|
|
|
|
procedure TFpPascalExpressionPartOperatorPlusMinus.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_PLUS_MINUS;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorPlusMinus.DoGetResultValue: TFpDbgValue;
|
|
{$PUSH}{$R-}{$Q-}
|
|
function AddSubValueToPointer(APointerVal, AOtherVal: TFpDbgValue; ADoSubtract: Boolean = False): TFpDbgValue;
|
|
var
|
|
Idx: Int64;
|
|
TmpVal: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
// skPointer: Result := nil;
|
|
skInteger: Idx := AOtherVal.AsInteger;
|
|
skCardinal: begin
|
|
Idx := AOtherVal.AsInteger;
|
|
if Idx > High(Int64) then
|
|
exit; // TODO: error
|
|
end;
|
|
else
|
|
exit; // TODO: error
|
|
end;
|
|
if ADoSubtract then begin
|
|
if Idx < -(High(Int64)) then
|
|
exit; // TODO: error
|
|
Idx := -Idx;
|
|
end;
|
|
TmpVal := APointerVal.Member[Idx];
|
|
if IsError(APointerVal.LastError) then begin
|
|
SetError('Error dereferencing'); // TODO: set correct error
|
|
exit;
|
|
end;
|
|
Result := TFpPasParserValueAddressOf.Create(TmpVal, Expression.Context);
|
|
end;
|
|
function AddValueToInt(AIntVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skPointer: Result := AddSubValueToPointer(AOtherVal, AIntVal);
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger + AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger + AOtherVal.AsCardinal, True);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger + AOtherVal.AsFloat);
|
|
else SetError('Addition not supported');
|
|
end;
|
|
end;
|
|
function AddValueToCardinal(ACardinalVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skPointer: Result := AddSubValueToPointer(AOtherVal, ACardinalVal);
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal + AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal + AOtherVal.AsCardinal, False);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal + AOtherVal.AsFloat);
|
|
else SetError('Addition not supported');
|
|
end;
|
|
end;
|
|
function AddValueToFloat(AFloatVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsFloat);
|
|
else SetError('Addition not supported');
|
|
end;
|
|
end;
|
|
|
|
function SubPointerFromValue(APointerVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil; // Error
|
|
end;
|
|
function SubValueFromInt(AIntVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skPointer: Result := SubPointerFromValue(AOtherVal, AIntVal);
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger - AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger - AOtherVal.AsCardinal, True);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger - AOtherVal.AsFloat);
|
|
else SetError('Subtraction not supported');
|
|
end;
|
|
end;
|
|
function SubValueFromCardinal(ACardinalVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skPointer: Result := SubPointerFromValue(AOtherVal, ACardinalVal);
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal - AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal - AOtherVal.AsCardinal, False);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal - AOtherVal.AsFloat);
|
|
else SetError('Subtraction not supported');
|
|
end;
|
|
end;
|
|
function SubValueFromFloat(AFloatVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsFloat);
|
|
else SetError('Subtraction not supported');
|
|
end;
|
|
end;
|
|
{$POP}
|
|
var
|
|
tmp1, tmp2: TFpDbgValue;
|
|
IsAdd: Boolean;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 2 then exit;
|
|
assert((GetText = '+') or (GetText = '-'), 'TFpPascalExpressionPartOperatorUnaryPlusMinus.DoGetResultValue: (GetText = +) or (GetText = -)');
|
|
|
|
tmp1 := Items[0].ResultValue;
|
|
tmp2 := Items[1].ResultValue;
|
|
IsAdd := GetText = '+';
|
|
if (tmp1 = nil) or (tmp2 = nil) then exit;
|
|
|
|
if IsAdd then begin
|
|
case tmp1.Kind of
|
|
skPointer: Result := AddSubValueToPointer(tmp1, tmp2);
|
|
skInteger: Result := AddValueToInt(tmp1, tmp2);
|
|
skCardinal: Result := AddValueToCardinal(tmp1, tmp2);
|
|
skFloat: Result := AddValueToFloat(tmp1, tmp2);
|
|
end;
|
|
end
|
|
else begin
|
|
case tmp1.Kind of
|
|
skPointer: Result := AddSubValueToPointer(tmp1, tmp2, True);
|
|
skInteger: Result := SubValueFromInt(tmp1, tmp2);
|
|
skCardinal: Result := SubValueFromCardinal(tmp1, tmp2);
|
|
skFloat: Result := SubValueFromFloat(tmp1, tmp2);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then
|
|
Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMulDiv }
|
|
|
|
procedure TFpPascalExpressionPartOperatorMulDiv.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_MUL_DIV;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMulDiv.DoGetResultValue: TFpDbgValue;
|
|
{$PUSH}{$R-}{$Q-}
|
|
function MultiplyIntWithValue(AIntVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger * AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger * AOtherVal.AsCardinal, True);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger * AOtherVal.AsFloat);
|
|
else SetError('Multiply not supported');
|
|
end;
|
|
end;
|
|
function MultiplyCardinalWithValue(ACardinalVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal * AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal * AOtherVal.AsCardinal, False);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal * AOtherVal.AsFloat);
|
|
else SetError('Multiply not supported');
|
|
end;
|
|
end;
|
|
function MultiplyFloatWithValue(AFloatVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsFloat);
|
|
else SetError('Multiply not supported');
|
|
end;
|
|
end;
|
|
|
|
function FloatDivIntByValue(AIntVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsFloat);
|
|
else SetError('/ not supported');
|
|
end;
|
|
end;
|
|
function FloatDivCardinalByValue(ACardinalVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsFloat);
|
|
else SetError('/ not supported');
|
|
end;
|
|
end;
|
|
function FloatDivFloatByValue(AFloatVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsInteger);
|
|
skCardinal: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsCardinal);
|
|
skFloat: Result := TFpDbgValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsFloat);
|
|
else SetError('/ not supported');
|
|
end;
|
|
end;
|
|
|
|
function NumDivIntByValue(AIntVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger div AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(AIntVal.AsInteger div AOtherVal.AsCardinal, True);
|
|
else SetError('Div not supported');
|
|
end;
|
|
end;
|
|
function NumDivCardinalByValue(ACardinalVal, AOtherVal: TFpDbgValue): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal div AOtherVal.AsInteger, True);
|
|
skCardinal: Result := TFpDbgValueConstNumber.Create(ACardinalVal.AsCardinal div AOtherVal.AsCardinal, False);
|
|
else SetError('Div not supported');
|
|
end;
|
|
end;
|
|
{$POP}
|
|
var
|
|
tmp1, tmp2: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 2 then exit;
|
|
assert((GetText = '*') or (GetText = '/') or (LowerCase(GetText) = 'div') , 'TFpPascalExpressionPartOperatorUnaryPlusMinus.DoGetResultValue: (GetText = +) or (GetText = -)');
|
|
|
|
tmp1 := Items[0].ResultValue;
|
|
tmp2 := Items[1].ResultValue;
|
|
if (tmp1 = nil) or (tmp2 = nil) then exit;
|
|
|
|
if GetText = '*' then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := MultiplyIntWithValue(tmp1, tmp2);
|
|
skCardinal: Result := MultiplyCardinalWithValue(tmp1, tmp2);
|
|
skFloat: Result := MultiplyFloatWithValue(tmp1, tmp2);
|
|
end;
|
|
end
|
|
else
|
|
if GetText = '/' then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := FloatDivIntByValue(tmp1, tmp2);
|
|
skCardinal: Result := FloatDivCardinalByValue(tmp1, tmp2);
|
|
skFloat: Result := FloatDivFloatByValue(tmp1, tmp2);
|
|
end;
|
|
end
|
|
else
|
|
if LowerCase(GetText) = 'div' then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := NumDivIntByValue(tmp1, tmp2);
|
|
skCardinal: Result := NumDivCardinalByValue(tmp1, tmp2);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then
|
|
Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorCompare }
|
|
|
|
procedure TFpPascalExpressionPartOperatorCompare.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_COMPARE;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorCompare.DoGetResultValue: TFpDbgValue;
|
|
{$PUSH}{$R-}{$Q-}
|
|
function IntEqualToValue(AIntVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function CardinalEqualToValue(ACardinalVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function FloatEqualToValue(AFloatVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
|
|
function IntGreaterThanValue(AIntVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function CardinalGreaterThanValue(ACardinalVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function FloatGreaterThanValue(AFloatVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
|
|
function IntSmallerThanValue(AIntVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function CardinalSmallerThanValue(ACardinalVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
function FloatSmallerThanValue(AFloatVal, AOtherVal: TFpDbgValue; ARevert: Boolean = False): TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
case AOtherVal.Kind of
|
|
skInteger: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsInteger) xor ARevert);
|
|
skCardinal: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsCardinal) xor ARevert);
|
|
skFloat: Result := TFpDbgValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsFloat) xor ARevert);
|
|
else SetError('= not supported');
|
|
end;
|
|
end;
|
|
|
|
{$POP}
|
|
var
|
|
tmp1, tmp2: TFpDbgValue;
|
|
s: String;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 2 then exit;
|
|
|
|
tmp1 := Items[0].ResultValue;
|
|
tmp2 := Items[1].ResultValue;
|
|
if (tmp1 = nil) or (tmp2 = nil) then exit;
|
|
s := GetText;
|
|
|
|
if (s = '=') or (s = '<>') then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := IntEqualToValue(tmp1, tmp2, (s = '<>'));
|
|
skCardinal: Result := CardinalEqualToValue(tmp1, tmp2, (s = '<>'));
|
|
skFloat: Result := FloatEqualToValue(tmp1, tmp2, (s = '<>'));
|
|
end;
|
|
end
|
|
else
|
|
if (s = '>') or (s = '<=') then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := IntGreaterThanValue(tmp1, tmp2, (s = '<='));
|
|
skCardinal: Result := CardinalGreaterThanValue(tmp1, tmp2, (s = '<='));
|
|
skFloat: Result := FloatGreaterThanValue(tmp1, tmp2, (s = '<='));
|
|
end;
|
|
end
|
|
else
|
|
if (s = '<') or (s = '>=') then begin
|
|
case tmp1.Kind of
|
|
skInteger: Result := IntSmallerThanValue(tmp1, tmp2, (s = '>='));
|
|
skCardinal: Result := CardinalSmallerThanValue(tmp1, tmp2, (s = '>='));
|
|
skFloat: Result := FloatSmallerThanValue(tmp1, tmp2, (s = '>='));
|
|
end;
|
|
end
|
|
else
|
|
if GetText = '><' then begin
|
|
// compare SET
|
|
end;
|
|
|
|
{$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then
|
|
Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF}
|
|
end;
|
|
|
|
{ TFpPascalExpressionPartOperatorMemberOf }
|
|
|
|
procedure TFpPascalExpressionPartOperatorMemberOf.Init;
|
|
begin
|
|
FPrecedence := PRECEDENCE_MEMBER_OF;
|
|
inherited Init;
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMemberOf.IsValidNextPart(APart: TFpPascalExpressionPart): Boolean;
|
|
begin
|
|
Result := inherited IsValidNextPart(APart);
|
|
if not HasAllOperands then
|
|
Result := Result and (APart is TFpPascalExpressionPartIdentifier);
|
|
end;
|
|
|
|
function TFpPascalExpressionPartOperatorMemberOf.DoGetResultValue: TFpDbgValue;
|
|
var
|
|
tmp: TFpDbgValue;
|
|
begin
|
|
Result := nil;
|
|
if Count <> 2 then exit;
|
|
|
|
tmp := Items[0].ResultValue;
|
|
if (tmp = nil) then exit;
|
|
|
|
if (tmp.Kind in [skClass, skRecord, skObject]) then begin
|
|
Result := tmp.MemberByName[Items[1].GetText];
|
|
if Result = nil then begin
|
|
SetError(fpErrNoMemberWithName, [Items[1].GetText]);
|
|
exit;
|
|
end;
|
|
Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF};
|
|
Assert((Result.DbgSymbol=nil)or(Result.DbgSymbol.SymbolType=stValue), 'member is value');
|
|
exit;
|
|
end;
|
|
|
|
// Todo unit
|
|
|
|
SetError(fpErrorNotAStructure, [Items[1].GetText, Items[0].GetText]);
|
|
|
|
end;
|
|
|
|
end.
|
|
|