{ --------------------------------------------------------------------------- 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 . 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+} {$ModeSwitch advancedrecords} {$IFDEF INLINE_OFF}{$INLINE OFF}{$ENDIF} {$IF FPC_Fullversion=30202}{$Optimization NOPEEPHOLE}{$ENDIF} {$TYPEDADDRESS on} {$SafeFPUExceptions off} interface uses Classes, sysutils, math, fgl, DbgIntfBaseTypes, LazDebuggerIntfFloatTypes, FpDbgInfo, FpdMemoryTools, FpErrorMessages, FpDbgDwarf, FpWatchResultData, FpDbgClasses, {$ifdef FORCE_LAZLOGGER_DUMMY} LazLoggerDummy {$else} LazLoggerBase {$endif}, LazClasses; const MAX_ERR_EXPR_QUOTE_LEN = 200; type TFpPascalExpressionPartList= class; TFpPascalExpression = class; TFpPascalExpressionPart = class; TFpPascalExpressionPartContainer = class; TFpPascalExpressionPartWithPrecedence = class; TFpPascalExpressionPartBracket = class; TFpPascalExpressionPartOperator = class; TFpPascalExpressionPartIntrinsicBase = class; TFpPascalExpressionPartOperatorArraySlice = class; PFpPascalExpressionPartOperatorArraySlice = ^TFpPascalExpressionPartOperatorArraySlice; TFpPascalExpressionPartClass = class of TFpPascalExpressionPart; TFpPascalExpressionPartBracketClass = class of TFpPascalExpressionPartBracket; TSeparatorType = (ppstComma); TFpIntrinsicPrefix = (ipColon, ipExclamation, ipNoPrefix); TFpIntrinsicFunc = ( ifErrorNotFound, ifChildClass, ifTry, ifTryN, ifObj, ifFlatten, ifFlattenPlaceholder, ifLength, ifRefCount, ifPos, ifSubStr, ifLower, ifUpper, ifOrd, ifRound, ifTrunc, ifSqrt, ifPi, ifLn, ifLog, ifSin, ifCos, ifTan ); TFpPascalParserGetSymbolForIdentProc = function(APart: TFpPascalExpressionPart; AnIdent: String): TFpValue of object; TFpPascalParserGetIntrinsicForIdentProc = function(AnExpression: TFpPascalExpression; AStart: PChar; ALen: Integer): TFpPascalExpressionPartIntrinsicBase of object; TFpPascalParserCallFunctionProc = function (AnExpressionPart: TFpPascalExpressionPart; AFunctionValue: TFpValue; ASelfValue: TFpValue; AParams: TFpPascalExpressionPartList; out AResult: TFpValue; var AnError: TFpError): boolean of object; { TFpPascalExpressionSharedData } TFpPascalExpressionSharedData = class(TRefCountedObject) // Data used while EVALUATING the expression result strict private FTextExpression: String; FScope: TFpDbgSymbolScope; FError: TFpError; FAutoDeref: Boolean; FFixPCharIndexAccess: Boolean; FOnFunctionCall: TFpPascalParserCallFunctionProc; FGlobalCache: TFpDbgDataCache; function GetTextExpressionAddr: PChar; inline; function GetValid: Boolean; protected FHasPCharIndexAccess: Boolean; public constructor Create(ATextExpression: String; AScope: TFpDbgSymbolScope); destructor Destroy; override; function GetDbgSymbolForIdentifier({%H-}AnIdent: String; AFindFlags: TFindExportedSymbolsFlags = []): TFpValue; function GetRegisterValue({%H-}AnIdent: String): TFpValue; procedure SetError(AMsg: String); // deprecated; procedure SetError(AnErrorCode: TFpErrorCode; const AnNestedErr: TFpError = nil); procedure SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError = nil); procedure SetError(const AnErr: TFpError); procedure ClearError; function PosFromPChar(APChar: PChar): Integer; property TextExpression: String read FTextExpression; property TextExpressionAddr: PChar read GetTextExpressionAddr; property Scope: TFpDbgSymbolScope read FScope; property Error: TFpError read FError; property Valid: Boolean read GetValid; (* *** CONFIG *** *) property AutoDeref: Boolean read FAutoDeref write FAutoDeref; property HasPCharIndexAccess: Boolean read FHasPCharIndexAccess; // Set by GetResultValue property FixPCharIndexAccess: Boolean read FFixPCharIndexAccess write FFixPCharIndexAccess; // handle pchar as string (adjust index) property OnFunctionCall: TFpPascalParserCallFunctionProc read FOnFunctionCall write FOnFunctionCall; property GlobalCache: TFpDbgDataCache read FGlobalCache write FGlobalCache; end; { TFpPascalExpression } TFpPascalExpression = class strict private FSharedData: TFpPascalExpressionSharedData; function GetAutoDeref: Boolean; inline; function GetFixPCharIndexAccess: Boolean; inline; function GetHasPCharIndexAccess: Boolean; inline; function GetGlobalCache: TFpDbgDataCache; inline; function GetOnFunctionCall: TFpPascalParserCallFunctionProc; inline; procedure SetAutoDeref(AValue: Boolean); inline; procedure SetFixPCharIndexAccess(AValue: Boolean); inline; procedure SetGlobalCache(AValue: TFpDbgDataCache); inline; procedure SetOnFunctionCall(AValue: TFpPascalParserCallFunctionProc); inline; function GetError: TFpError; inline; function GetValid: Boolean; inline; strict private FOnFindIntrinsc: TFpPascalParserGetIntrinsicForIdentProc; FIntrinsicPrefix: TFpIntrinsicPrefix; FExpressionPart: TFpPascalExpressionPart; FPreviousArraySlice: TFpPascalExpressionPartOperatorArraySlice; function GetResultValue: TFpValue; function LookupIntrinsic(AStart: PChar; ALen: Integer): TFpPascalExpressionPart; protected procedure SetError(AnErrorCode: TFpErrorCode; const AnNestedErr: TFpError = nil); procedure SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError = nil); protected property ExpressionPart: TFpPascalExpressionPart read FExpressionPart; public constructor Create(ATextExpression: String; AScope: TFpDbgSymbolScope; ASkipParse: Boolean = False); destructor Destroy; override; procedure Parse; function DebugDump(AWithResults: Boolean = False): String; procedure ResetEvaluation; // property TextExpression: String read GetTextExpression; property Error: TFpError read GetError; property Valid: Boolean read GetValid; // ResultValue // - May be a type, if expression is a type // - Only valid, as long as the expression is not destroyed property ResultValue: TFpValue read GetResultValue; (* *** CONFIG *** *) // Parser-only property IntrinsicPrefix: TFpIntrinsicPrefix read FIntrinsicPrefix write FIntrinsicPrefix; property OnFindIntrinsc: TFpPascalParserGetIntrinsicForIdentProc read FOnFindIntrinsc write FOnFindIntrinsc; // Shared, available during evaluation property AutoDeref: Boolean read GetAutoDeref write SetAutoDeref; property HasPCharIndexAccess: Boolean read GetHasPCharIndexAccess; // Set by GetResultValue property FixPCharIndexAccess: Boolean read GetFixPCharIndexAccess write SetFixPCharIndexAccess; // handle pchar as string (adjust index) property OnFunctionCall: TFpPascalParserCallFunctionProc read GetOnFunctionCall write SetOnFunctionCall; property GlobalCache: TFpDbgDataCache read GetGlobalCache write SetGlobalCache; property SharedData: TFpPascalExpressionSharedData read FSharedData; end; { TFpPascalExpressionPartList } TFpPascalExpressionPartList = class(TStrings) public // TStrings procedure Clear; override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: string); override; protected // TStrings function Get(Index: Integer): string; override; //function GetCount: Integer; virtual; abstract; protected function GetItems(AIndex: Integer): TFpPascalExpressionPart; virtual; abstract; public //property Count: Integer read GetCount; property Items[AIndex: Integer]: TFpPascalExpressionPart read GetItems; end; TFindInParentsFlag = (fipIncludeBracketFunction); TFindInParentsFlags = set of TFindInParentsFlag; { TFpPascalExpressionPart } TFpPascalExpressionPart = class private FExpressionData: TFpPascalExpressionSharedData; FEndChar: PChar; FParent: TFpPascalExpressionPartContainer; FStartChar: PChar; FResultValue: TFpValue; FResultValDone: Boolean; FIsCopy: Boolean; function GetResultValue: TFpValue; function GetSurroundingOpenBracket: TFpPascalExpressionPartBracket; function GetTopParent: TFpPascalExpressionPart; procedure SetEndChar(AValue: PChar); procedure SetParent(AValue: TFpPascalExpressionPartContainer); virtual; procedure SetStartChar(AValue: PChar); function CreateErrorWithPos(AnErrorCode: TFpErrorCode; AData: array of const; APos: integer = -1): TFpError; procedure SetErrorWithPos(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 FPrecedence: Integer; procedure Init; virtual; procedure Assign(ASourcePart: TFpPascalExpressionPart); virtual; function FindCopiedInParents(ASourcePart, AFindInSourcePart: TFpPascalExpressionPart; AFindFlags: TFindInParentsFlags = []): TFpPascalExpressionPart; function DoGetIsTypeCast: Boolean; virtual; deprecated; function DoGetResultValue: TFpValue; virtual; procedure SetError(AMsg: String = ''); // deprecated; procedure SetError(APart: TFpPascalExpressionPart; AMsg: String = ''); // deprecated; //procedure SetError(AnErrorCode: TFpErrorCode; const AnNestedErr: TFpError = nil); procedure SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError = nil); procedure SetError(AnError: TFpError); procedure ResetEvaluation; virtual; procedure ResetEvaluationRecursive; virtual; procedure ResetEvaluationForAnchestors; virtual; Procedure ReplaceInParent(AReplacement: TFpPascalExpressionPart); procedure DoHandleEndOfExpression; virtual; procedure DoParentIndexBraceClosed(APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); virtual; // called on index-Item in array[XXX] 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; var APart: TFpPascalExpressionPart): Boolean; virtual; // False procedure GetFirstLastChar(out AFirst, ALast: PChar); virtual; public constructor Create(AnExpressionData: TFpPascalExpressionSharedData; AStartChar: PChar; AnEndChar: PChar = nil); destructor Destroy; override; function CreateCopy(ACopiedParent: TFpPascalExpressionPartContainer): TFpPascalExpressionPart; procedure BeginNeedCopy; virtual; procedure EndNeedCopy; virtual; function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; virtual; procedure HandleEndOfExpression; virtual; // AcceptParamAsSeparator: called on the first Item in TFpPascalExpressionPartBracketArgumentList function AcceptParamAsSeparator(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer; var AResult: TFpPascalExpressionPart): boolean; virtual; // HandleNewParameterInList: called on the first Item in TFpPascalExpressionPartBracketArgumentList procedure HandleNewParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); virtual; procedure HandleEndOfParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); virtual; function GetText(AMaxLen: Integer=0): String; function GetPos: Integer; function GetFullText(AMaxLen: Integer=0): String; virtual; // including children function ReturnsVariant: boolean; virtual; function IsClosed: boolean; virtual; // for brackets property StartChar: PChar read FStartChar write SetStartChar; property EndChar: PChar read FEndChar write SetEndChar; property Parent: TFpPascalExpressionPartContainer read FParent write SetParent; function FindInParents(APart: TFpPascalExpressionPart): Boolean; property TopParent: TFpPascalExpressionPart read GetTopParent; // or self property Precedence: Integer read FPrecedence; property SurroundingBracket: TFpPascalExpressionPartBracket read GetSurroundingOpenBracket; // incl self property ResultValue: TFpValue read GetResultValue; property ExpressionData: TFpPascalExpressionSharedData read FExpressionData; 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; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; procedure ResetEvaluationRecursive; override; procedure GetFirstLastChar(out AFirst, ALast: PChar); override; function DebugDump(AIndent: String; AWithResults: Boolean): String; override; public destructor Destroy; override; procedure BeginNeedCopy; override; procedure EndNeedCopy; override; function GetFullText(AMaxLen: Integer=0): String; override; // including children 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) private FOnGetSymbol: TFpPascalParserGetSymbolForIdentProc; protected function DoGetIsTypeCast: Boolean; override; function DoGetResultValue: TFpValue; override; property OnGetSymbol: TFpPascalParserGetSymbolForIdentProc read FOnGetSymbol write FOnGetSymbol; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; procedure ResetEvaluation; override; end; { TFpPascalExpressionPartCpuRegister } TFpPascalExpressionPartCpuRegister = class(TFpPascalExpressionPartContainer) protected function DoGetResultValue: TFpValue; override; end; TFpPascalExpressionPartBracketArgumentList = class; { TFpPascalExpressionPartIntrinsicBase } TFpPascalExpressionPartIntrinsicBase = class(TFpPascalExpressionPartContainer) protected function CheckArgumentCount(AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer; AMaxAccepted: Integer = -1): Boolean; // GetArg; ANum is 1 based function GetArg(AParams: TFpPascalExpressionPartBracketArgumentList; ANum: Integer; out AValue: TFpValue; AnErr: String = ''): Boolean; function DoGetResultValue: TFpValue; override; function DoGetResultValue(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; virtual; end; { TFpPascalExpressionPartIntrinsic } TFpPascalExpressionPartIntrinsic = class(TFpPascalExpressionPartIntrinsicBase) private FIntrinsic: TFpIntrinsicFunc; FChildClassCastType: TFpValue; FFlattenCurrentVal, FFlattenCurrentValOrig: TFpValue; FFlattenMemberName: String; FFlattenMemberNotFound: boolean; function DoGetMemberForFlattenExpr(APart: TFpPascalExpressionPart; AnIdent: String): TFpValue; protected function DoTry(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoTryN(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoObj(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoOrd(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoLength(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoChildClass(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoFlatten(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoFlattenPlaceholder(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoRefCnt(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoPos(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoSubStr(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoLower(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoUpper(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoRound(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoTrunc(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoSqrt(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoPi(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoLn(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoLog(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoSin(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoCos(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoTan(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; function DoGetResultValue: TFpValue; override; function DoGetResultValue(AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; override; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; public constructor Create(AnExpressionData: TFpPascalExpressionSharedData; AStartChar: PChar; AnEndChar: PChar; AnIntrinsic: TFpIntrinsicFunc); destructor Destroy; override; function ReturnsVariant: boolean; override; function AcceptParamAsSeparator(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer; var AResult: TFpPascalExpressionPart ): boolean; override; procedure HandleNewParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); override; procedure HandleEndOfParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); override; end; TFpPascalExpressionPartConstant = class(TFpPascalExpressionPartContainer) end; { TFpPascalExpressionPartConstantNumber } TFpPascalExpressionPartConstantNumber = class(TFpPascalExpressionPartConstant) protected function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartConstantNumberFloat } TFpPascalExpressionPartConstantNumberFloat = class(TFpPascalExpressionPartConstantNumber) protected function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartConstantText } TFpPascalExpressionPartConstantText = class(TFpPascalExpressionPartConstant) protected FValue: String; function DoGetResultValue: TFpValue; override; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; end; { TFpPascalExpressionPartWithPrecedence } TFpPascalExpressionPartWithPrecedence = class(TFpPascalExpressionPartContainer) protected function HasPrecedence: Boolean; override; end; { TFpPascalExpressionPartBracket } TFpPascalExpressionPartBracket = class(TFpPascalExpressionPartWithPrecedence) // some, but not all bracket expr have precedence private FIsClosed: boolean; FIsClosing: boolean; FIsSeparatorChecking: boolean; FAfterComma: Integer; FFullEndChar: PChar; 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; procedure GetFirstLastChar(out AFirst, ALast: PChar); override; procedure CheckBeforeSeparator(APart: TFpPascalExpressionPart); procedure Assign(ASourcePart: TFpPascalExpressionPart); override; public procedure CloseBracket(ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar = nil); virtual; function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override; procedure HandleEndOfExpression; override; function IsClosed: boolean; override; end; { TFpPascalExpressionPartRoundBracket } TFpPascalExpressionPartRoundBracket = class(TFpPascalExpressionPartBracket) protected end; { TFpPascalExpressionPartBracketSubExpression } TFpPascalExpressionPartBracketSubExpression = class(TFpPascalExpressionPartRoundBracket) protected function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override; function DoGetResultValue: TFpValue; override; function HandleSeparator(ASeparatorType: TSeparatorType; var APart: TFpPascalExpressionPart): Boolean; override; public procedure CloseBracket(ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar = nil); 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: TFpValue; 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; var APart: TFpPascalExpressionPart): Boolean; override; public procedure CloseBracket(ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar = nil); override; function ReturnsVariant: boolean; override; function IntrinsicType: TFpIntrinsicFunc; end; { TFpPascalExpressionPartSquareBracket } TFpPascalExpressionPartSquareBracket = class(TFpPascalExpressionPartBracket) end; { TFpPascalExpressionPartBracketSet } TFpPascalExpressionPartBracketSet = class(TFpPascalExpressionPartSquareBracket) // a in [x, y, z] protected function DoGetResultValue: TFpValue; override; function HandleNextPartInBracket(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override; function HandleSeparator(ASeparatorType: TSeparatorType; var APart: TFpPascalExpressionPart): Boolean; override; end; { TFpPascalExpressionPartBracketIndex } TFpPascalExpressionPartBracketIndex = class(TFpPascalExpressionPartSquareBracket) // array[1] protected procedure Init; override; function DoGetResultValue: TFpValue; 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; var APart: TFpPascalExpressionPart): Boolean; override; public procedure CloseBracket(ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar = nil); 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; var APart: TFpPascalExpressionPart): 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; function IsValidAfterPartWithPrecedence(APrevPart: TFpPascalExpressionPart): Boolean; virtual; public function HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; override; function MaybeHandlePrevPart(APrevPart: TFpPascalExpressionPart; var AResult: TFpPascalExpressionPart): Boolean; override; end; { TFpPascalExpressionPartOperatorAddressOf } TFpPascalExpressionPartOperatorAddressOf = class(TFpPascalExpressionPartUnaryOperator) // @ protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorMakeRef } TFpPascalExpressionPartOperatorMakeRef = class(TFpPascalExpressionPartUnaryOperator) // ^TTYpe protected procedure Init; override; function IsValidNextPart(APart: TFpPascalExpressionPart): Boolean; override; function DoGetResultValue: TFpValue; override; function DoGetIsTypeCast: Boolean; override; end; { TFpPascalExpressionPartOperatorDeRef } TFpPascalExpressionPartOperatorDeRef = class(TFpPascalExpressionPartUnaryOperator) // ptrval^ protected procedure Init; override; function DoGetResultValue: TFpValue; 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: TFpValue; override; end; { TFpPascalExpressionPartOperatorQuestionMark } TFpPascalExpressionPartOperatorQuestionMark = class(TFpPascalExpressionPartBinaryOperator) // ? : protected procedure Init; override; function DoGetResultValue: TFpValue; override; function FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence ): TFpPascalExpressionPart; override; function IsValidAfterPartWithPrecedence(APrevPart: TFpPascalExpressionPart): Boolean; override; procedure DoHandleEndOfExpression; override; public function ReturnsVariant: boolean; override; function IsClosed: boolean; override; end; { TFpPascalExpressionPartOperatorColon } TFpPascalExpressionPartOperatorColon = class(TFpPascalExpressionPartBinaryOperator) // ? : private FIsClosed: boolean; protected procedure Init; override; function DoGetResultValue: TFpValue; override; function FindLeftSideOperandByPrecedence(AnOperator: TFpPascalExpressionPartWithPrecedence ): TFpPascalExpressionPart; override; function IsValidAfterPartWithPrecedence(APrevPart: TFpPascalExpressionPart): Boolean; override; procedure DoHandleEndOfExpression; override; public function IsClosed: boolean; override; end; { TFpPascalExpressionPartOperatorPlusMinus } TFpPascalExpressionPartOperatorPlusMinus = class(TFpPascalExpressionPartBinaryOperator) // + - // Binary + - protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorMulDiv } TFpPascalExpressionPartOperatorMulDiv = class(TFpPascalExpressionPartBinaryOperator) // * / protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorUnaryNot } TFpPascalExpressionPartOperatorUnaryNot = class(TFpPascalExpressionPartUnaryOperator) // not protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorAnd } TFpPascalExpressionPartOperatorAnd = class(TFpPascalExpressionPartBinaryOperator) // AND protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorBitShift } TFpPascalExpressionPartOperatorBitShift = class(TFpPascalExpressionPartBinaryOperator) // shr shl << >> protected procedure Init; override; function CheckOperators(out AVal, AShift: QWord): boolean; end; { TFpPascalExpressionPartOperatorShr } TFpPascalExpressionPartOperatorShr = class(TFpPascalExpressionPartOperatorBitShift) // shr >> protected function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorShl } TFpPascalExpressionPartOperatorShl = class(TFpPascalExpressionPartOperatorBitShift) // shl << protected function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorOr } TFpPascalExpressionPartOperatorOr = class(TFpPascalExpressionPartBinaryOperator) // OR XOR public type TOpOrType = (ootOr, ootXor); protected FOp: TOpOrType; procedure Init; override; function DoGetResultValue: TFpValue; override; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; public constructor Create(AnExpressionData: TFpPascalExpressionSharedData; AnOp: TOpOrType; AStartChar: PChar; AnEndChar: PChar = nil); end; { TFpPascalExpressionPartOperatorCompare } TFpPascalExpressionPartOperatorCompare = class(TFpPascalExpressionPartBinaryOperator) // = < > <> >< protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorMemberOf } TFpPascalExpressionPartOperatorMemberOf = class(TFpPascalExpressionPartBinaryOperator) // struct.member protected procedure Init; override; function IsValidNextPart(APart: TFpPascalExpressionPart): Boolean; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorMemberIn } TFpPascalExpressionPartOperatorMemberIn = class(TFpPascalExpressionPartBinaryOperator) // enum in set protected procedure Init; override; function DoGetResultValue: TFpValue; override; end; { TFpPascalExpressionPartOperatorArraySliceController } TFpPascalExpressionPartOperatorArraySliceController = class(TFpPascalExpressionPartBracketSubExpression) private FDisableSlice: boolean; FSlicePart: TFpPascalExpressionPartOperatorArraySlice; FInResetEvaluationForIndex: Boolean; FHasVariantPart: Boolean; FCheckedForVariantPart: Boolean; FNeedCopy: integer; function GetCanDisableSlice: boolean; protected function DoGetResultValue: TFpValue; override; function InternalDoGetResultValue(ANeedCopy: boolean): TFpValue; procedure DoParentIndexBraceClosed(APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); override; procedure ResetEvaluation; override; procedure ResetEvaluationForIndex; procedure ResetEvaluationForAnchestors; override; public constructor Create(AnExpressionData: TFpPascalExpressionSharedData; ASlicePart: TFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar = nil); procedure BeginNeedCopy; override; procedure EndNeedCopy; override; function GetFullText(AMaxLen: Integer = 0): String; override; function DebugText(AIndent: String; AWithResults: Boolean): String; override; property SlicePart: TFpPascalExpressionPartOperatorArraySlice read FSlicePart; property DisableSlice: boolean read FDisableSlice write FDisableSlice; property CanDisableSlice: boolean read GetCanDisableSlice; end; { TFpPascalExpressionPartOperatorArraySlice } TFpPascalExpressionPartOperatorArraySlice = class(TFpPascalExpressionPartBinaryOperator) // enum in set private FCurrentIndex: Int64; FController: TFpPascalExpressionPartOperatorArraySliceController; FPreviousArraySlice: TFpPascalExpressionPartOperatorArraySlice; FHasUpperLimit: Boolean; FUpperLimit: Integer; protected FTouched: boolean; procedure Init; override; procedure DoParentIndexBraceClosed(APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); override; function DoGetResultValue: TFpValue; override; function StartValue: Int64; function EndValue: Int64; procedure CheckForVariantExpressionParts; procedure Assign(ASourcePart: TFpPascalExpressionPart); override; public destructor Destroy; override; function IsClosed: boolean; override; function AddController(ACurPart: TFpPascalExpressionPart): TFpPascalExpressionPart; function AddControllerRecursive(ACurPart: TFpPascalExpressionPart): TFpPascalExpressionPart; property Controller: TFpPascalExpressionPartOperatorArraySliceController read FController; end; { TFpPasParserValueSlicedArrayIndex } TFpPasParserValueSlicedArrayIndex = class(TFpSymbol) private FLowBound: Int64; public function GetValueLowBound(AValueObj: TFpValue; out ALowBound: Int64): Boolean; override; end; { TFpPasParserValue } TFpPasParserValue = class(TFpValue) private FContext: TFpDbgSimpleLocationContext; // Pos and Text from expressionpart / used in errors FExprPos: Integer; FExprText: String; protected function DebugText(AIndent: String): String; virtual; function CreateErrorWithPos(AnErrorCode: TFpErrorCode; AData: array of const): TFpError; public constructor Create(AnExpressionPart: TFpPascalExpressionPart); constructor Create(AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String); property Context: TFpDbgSimpleLocationContext read FContext; end; { TFpPasParserValueSlicedArray } TFpPasParserValueSlicedArray = class(TFpPasParserValue) private FLowBoundIndex: TFpPasParserValueSlicedArrayIndex; FArraySlice: TFpPascalExpressionPartOperatorArraySliceController; FOwnsController: Boolean; FExpressionPartInValue: TFpPascalExpressionPart; protected //function DebugText(AIndent: String): String; override; function SlicePart: TFpPascalExpressionPartOperatorArraySlice; inline; protected function GetKind: TDbgSymbolKind; override; function GetFieldFlags: TFpValueFieldFlags; override; function GetTypeInfo: TFpSymbol; override; function GetMember(AIndex: Int64): TFpValue; override; function GetMemberCount: Integer; override; function GetIndexType(AIndex: Integer): TFpSymbol; override; function GetIndexTypeCount: Integer; override; function GetOrdLowBound: Int64; override; public constructor Create(ASlice: TFpPascalExpressionPartOperatorArraySliceController; AnOwnsController: boolean = False); destructor Destroy; override; function SliceBracketStartOffs: integer; function SliceBracketLength: integer; end; implementation var DBG_WARNINGS: PLazLoggerLogGroup; 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_UNARY_NOT = 11; // NOT a PRECEDENCE_MUL_DIV = 12; // a * b PRECEDENCE_AND = 12; // a AND b PRECEDENCE_BIT_SHIFT = 12; // << >> shr shr PRECEDENCE_PLUS_MINUS = 13; // a + b PRECEDENCE_OR = 13; // a OR b // XOR PRECEDENCE_IN = 19; // enum IN set // officially the same as PRECEDENCE_COMPARE PRECEDENCE_COMPARE = 20; // a <> b // a=b PRECEDENCE_QUEST_COLON= 27; // ? : PRECEDENCE_ARRAY_SLICE= 30; // array[5..9] // array slice PRECEDENCE_SEPARATOR_COLON= MaxInt; // : used as separator in intrinsics // Operator used to hold both sides type { TFpPascalExpressionPartListForwarder } TFpPascalExpressionPartListForwarder = class(TFpPascalExpressionPartList) private FExpressionPart: TFpPascalExpressionPartContainer; FListOffset, FCount: Integer; protected function GetCount: Integer; override; function GetItems(AIndex: Integer): TFpPascalExpressionPart; override; public constructor Create(AnExpressionPart: TFpPascalExpressionPartContainer; AListOffset, ACount: Integer); end; {%region DebugSymbol } { TPasParserSymbolPointer used by TFpPasParserValueMakeReftype.GetDbgSymbol } TPasParserSymbolPointer = class(TFpSymbol) private FPointerLevels: Integer; FPointedTo: TFpSymbol; FContext: TFpDbgSimpleLocationContext; // Pos and Text from expressionpart / used in errors FExprPos: Integer; FExprText: String; protected // NameNeeded // "^TPointedTo" procedure TypeInfoNeeded; override; function DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; override; public constructor Create(const APointedTo: TFpSymbol; AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String; APointerLevels: Integer); constructor Create(const APointedTo: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart; APointerLevels: Integer); constructor Create(const APointedTo: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart); destructor Destroy; override; function TypeCastValue(AValue: TFpValue): TFpValue; override; end; { TPasParserSymbolArrayDeIndex } TPasParserSymbolArrayDeIndex = class(TFpSymbolForwarder) // 1 index level off private FArray: TFpSymbol; protected //procedure ForwardToSymbolNeeded; override; function GetNestedSymbolCount: Integer; override; function GetNestedSymbol(AIndex: Int64): TFpSymbol; override; public constructor Create(const AnArray: TFpSymbol); destructor Destroy; override; end; {%endregion DebugSymbol } {%region DebugSymbolValue } { TFpPasParserValueCastToPointer used by TPasParserSymbolPointer.TypeCastValue (which is used by TFpPasParserValueMakeReftype.GetDbgSymbol) } TFpPasParserValueCastToPointer = class(TFpPasParserValue) private FValue: TFpValue; FTypeSymbol: TFpSymbol; protected function DebugText(AIndent: String): String; override; protected function GetKind: TDbgSymbolKind; override; function GetFieldFlags: TFpValueFieldFlags; override; function GetTypeInfo: TFpSymbol; override; function GetAsCardinal: QWord; override; function GetAsString: AnsiString; override; function GetAsWideString: WideString; override; function GetAddress: TFpDbgMemLocation; override; function GetDerefAddress: TFpDbgMemLocation; override; function GetMember(AIndex: Int64): TFpValue; override; public constructor Create(AValue: TFpValue; ATypeInfo: TFpSymbol; AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String); destructor Destroy; override; end; { TFpPasParserValueMakeReftype } TFpPasParserValueMakeReftype = class(TFpPasParserValue) private FSourceTypeSymbol, FTypeSymbol: TFpSymbol; FRefLevel: Integer; protected function DebugText(AIndent: String): String; override; protected function GetDbgSymbol: TFpSymbol; override; // returns a TPasParserSymbolPointer public constructor Create(ATypeInfo: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart); destructor Destroy; override; procedure IncRefLevel; function GetTypeCastedValue(ADataVal: TFpValue): TFpValue; override; end; { TFpPasParserValueDerefPointer Used as address source in typecast } TFpPasParserValueDerefPointer = class(TFpPasParserValue) private FValue: TFpValue; FAddressOffset: Int64; // Add to address FCardinal: QWord; // todo: TFpDbgMemLocation ? FCardinalRead: Boolean; protected function DebugText(AIndent: String): String; override; protected function GetFieldFlags: TFpValueFieldFlags; override; function GetAddress: TFpDbgMemLocation; override; function DoGetSize(out ASize: TFpDbgValueSize): Boolean; override; function GetAsCardinal: QWord; override; // reads men function GetTypeInfo: TFpSymbol; override; // TODO: Cardinal? Why? // TODO: does not handle AOffset public constructor Create(AValue: TFpValue; AnExpressionPart: TFpPascalExpressionPart); constructor Create(AValue: TFpValue; AnExpressionPart: TFpPascalExpressionPart; AOffset: Int64); destructor Destroy; override; end; { TFpPasParserValueAddressOf } TFpPasParserValueAddressOf = class(TFpPasParserValue) private FValue: TFpValue; FTypeInfo: TFpSymbol; function GetPointedToValue: TFpValue; protected function DebugText(AIndent: String): String; override; protected function GetKind: TDbgSymbolKind; override; function GetFieldFlags: TFpValueFieldFlags; override; function GetAsInteger: Int64; override; function GetAsCardinal: QWord; override; function GetTypeInfo: TFpSymbol; override; function GetDerefAddress: TFpDbgMemLocation; override; function GetMember(AIndex: Int64): TFpValue; override; function GetAsString: AnsiString; override; function GetAsWideString: WideString; override; public constructor Create(AValue: TFpValue; AnExpressionPart: TFpPascalExpressionPart); destructor Destroy; override; property PointedToValue: TFpValue read GetPointedToValue; end; {%endregion DebugSymbolValue } {%region Intrinsic Flatten} { TFpValueFlatteArray } TFpValueFlatteArray = class(TFpValueConstArray) private FList: TRefCntObjList; FFullEvaluated: boolean; protected function GetOrdHighBound: Int64; override; public constructor Create(ALowBound: Integer); destructor Destroy; override; function GetMember(AIndex: Int64): TFpValue; override; function GetMemberCount: Integer; override; end; PFpValueFlatteArray = ^TFpValueFlatteArray; TFpPascalExpressionFlattenFlag = ( iffShowNil, iffShowNoMember, iffShowRecurse, iffShowSeen, iffShowErrAny, iffDerefPtr, iffObj1, iffObj2, iffObj3, iffObj4 ); TFpPascalExpressionFlattenFlags = set of TFpPascalExpressionFlattenFlag; { TFpPascalExpressionCacheFlattenKey } TFpPascalExpressionCacheFlattenKey = record CtxThread, CtxStack: Integer; Key: String; Flags: TFpPascalExpressionFlattenFlags; ExpandArrayDepth: integer; class operator = (a,b: TFpPascalExpressionCacheFlattenKey): boolean; class operator < (a,b: TFpPascalExpressionCacheFlattenKey): boolean; class operator > (a,b: TFpPascalExpressionCacheFlattenKey): boolean; end; PFpPascalExpressionCacheFlattenKey = ^TFpPascalExpressionCacheFlattenKey; { TFpPascalExpressionCacheFlatten } TFpPascalExpressionCacheFlatten = class(specialize TFPGMap) private function DoKeyPtrComp(Key1, Key2: Pointer): Integer; protected procedure Deref(Item: Pointer); override; public constructor Create; function Add(const AKey: TFpPascalExpressionCacheFlattenKey; const AData: TFpValueFlatteArray): Integer; inline; function Replace(const AKey: TFpPascalExpressionCacheFlattenKey; const AData: TFpValueFlatteArray): Integer; inline; end; { TAddrSeenList } TAddrSeenList = class(specialize TFPGMap) private function DoKeyPtrComp(Key1, Key2: Pointer): Integer; public constructor Create; end; {%endregion Intrinsic Flatten} {%region Intrinsic Separator ":" } { TFpPascalExpressionPartOperatorColonAsSeparator } TFpPascalExpressionPartOperatorColonAsSeparator = class(TFpPascalExpressionPartBinaryOperator) // + - protected procedure Init; override; function DoGetResultValue: TFpValue; override; public function IsClosed: boolean; override; end; {%endregion Intrinsic Separator ":" } function DbgsResultValue(AVal: TFpValue; AIndent: String): String; begin if 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: TFpSymbol; {%H-}AIndent: String): String; begin Result := DbgSName(AVal); end; function ValueToExprText(AnValue: TFpValue; AMaxLen: Integer = 0): String; begin if AnValue is TFpPasParserValue then Result := TFpPasParserValue(AnValue).FExprText else if AnValue.DbgSymbol <> nil then Result := AnValue.DbgSymbol.Name else Result := '?'; end; procedure ForwardError(ATarget, ASrc: TFpValue); inline; begin if (ATarget = nil) or (ASrc = nil) then exit; if not IsError(ATarget.LastError) and IsError(ASrc.LastError) then ATarget.SetLastError(ASrc.LastError); end; procedure TFpPascalExpressionPartList.Clear; begin assert(False, 'TFpPascalExpressionPartList.Clear: False'); end; procedure TFpPascalExpressionPartList.Delete(Index: Integer); begin assert(False, 'TFpPascalExpressionPartList.Delete: False'); end; procedure TFpPascalExpressionPartList.Insert(Index: Integer; const S: string); begin assert(False, 'TFpPascalExpressionPartList.Insert: False'); end; function TFpPascalExpressionPartList.Get(Index: Integer): string; begin Result := Items[Index].GetText(); end; { TFpPascalExpressionPartListForwarder } function TFpPascalExpressionPartListForwarder.GetCount: Integer; begin Result := FCount; end; function TFpPascalExpressionPartListForwarder.GetItems(AIndex: Integer ): TFpPascalExpressionPart; begin Result := FExpressionPart.Items[AIndex + FListOffset]; end; constructor TFpPascalExpressionPartListForwarder.Create( AnExpressionPart: TFpPascalExpressionPartContainer; AListOffset, ACount: Integer); begin FExpressionPart := AnExpressionPart; FListOffset := AListOffset; FCount := ACount; end; function TFpPasParserValue.DebugText(AIndent: String): String; begin Result := AIndent + DbgSName(Self) + ' DbsSym='+DbgSName(DbgSymbol)+' Type='+DbgSName(TypeInfo) + LineEnding; end; function TFpPasParserValue.CreateErrorWithPos(AnErrorCode: TFpErrorCode; AData: array of const): TFpError; begin if FExprPos = 1 then Result := CreateError(AnErrorCode, AData, CreateError(fpErrPasParser_AtStart, [] )) else Result := CreateError(AnErrorCode, AData, CreateError(fpErrPasParser_Position, [FExprPos])); end; constructor TFpPasParserValue.Create(AnExpressionPart: TFpPascalExpressionPart); begin Create(AnExpressionPart.ExpressionData.Scope.LocationContext, AnExpressionPart.GetPos, AnExpressionPart.GetText(MAX_ERR_EXPR_QUOTE_LEN)); inherited Create; end; constructor TFpPasParserValue.Create(AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String); begin FContext := AContext; FExprPos := AnExprPos; FExprText := AnExprText; 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: TFpValueFieldFlags; var t: TFpSymbol; Size: TFpDbgValueSize; begin if (FValue.FieldFlags * [svfAddress, svfOrdinal] <> []) then begin Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress]; t := TypeInfo; if (t <> nil) then t := t.TypeInfo; if (t <> nil) and (t.Kind = skChar) and //(IsNilLoc(OrdOrDataAddr) or IsValidLoc(GetDerefAddress) //) // always true then begin // pchar if not t.ReadSize(nil, Size) then Size := ZeroSize; case Size.Size of 1: Result := Result + [svfString]; 2: Result := Result + [svfWideString]; end; end; end else Result := []; end; function TFpPasParserValueCastToPointer.GetTypeInfo: TFpSymbol; begin Result := FTypeSymbol; end; function TFpPasParserValueCastToPointer.GetAsCardinal: QWord; var f: TFpValueFieldFlags; begin Result := 0; f := FValue.FieldFlags; if svfOrdinal in f then Result := FValue.AsCardinal else if svfAddress in f then begin if not FContext.ReadUnsignedInt(FValue.Address, SizeVal(FContext.SizeOfAddress), Result) then begin Result := 0; SetLastError(FContext.LastMemError); end; end else begin if FValue is TFpPasParserValue then SetLastError(CreateErrorWithPos(fpErrCannotCastToPointer_p, [ValueToExprText(FValue, MAX_ERR_EXPR_QUOTE_LEN)] )); end; end; function TFpPasParserValueCastToPointer.GetAsString: AnsiString; var t: TFpSymbol; Size: TFpDbgValueSize; a: TFpDbgMemLocation; begin Result := ''; if (FValue = nil) or (Context.MemManager = nil) then exit; t := TypeInfo; if t <> nil then t := t.TypeInfo; if (t = nil) or (t.Kind <> skChar) then exit; a := GetDerefAddress; if not IsReadableMem(a) then exit; // Only test for hardcoded size. TODO: dwarf 3 could have variable size, but for char that is not expected if not t.ReadSize(nil, Size) then exit; if Size = 2 then Result := GetAsWideString else if Size = 1 then begin // pchar if not Context.MemManager.ReadPChar(a, 0, Result) then begin Result := ''; SetLastError(Context.LastMemError); exit; end; end else Result := inherited GetAsString; end; function TFpPasParserValueCastToPointer.GetAsWideString: WideString; var t: TFpSymbol; Size: TFpDbgValueSize; a: TFpDbgMemLocation; begin Result := ''; if (FValue = nil) or (Context.MemManager = nil) then exit; t := TypeInfo; if t <> nil then t := t.TypeInfo; if (t = nil) or (t.Kind <> skChar) then exit; a := GetDerefAddress; if not IsReadableMem(a) then exit; // Only test for hardcoded size. TODO: dwarf 3 could have variable size, but for char that is not expected if not t.ReadSize(nil, Size) then exit; if Size = 1 then Result := GetAsString else if Size = 2 then begin // pchar if not Context.MemManager.ReadPWChar(a, 0, Result) then begin Result := ''; SetLastError(Context.LastMemError); exit; end; end else Result := inherited GetAsWideString; end; function TFpPasParserValueCastToPointer.GetAddress: TFpDbgMemLocation; begin Result := FValue.Address; end; function TFpPasParserValueCastToPointer.GetDerefAddress: TFpDbgMemLocation; begin Result := TargetLoc(TDbgPtr(AsCardinal)); end; function TFpPasParserValueCastToPointer.GetMember(AIndex: Int64): TFpValue; var ti: TFpSymbol; addr: TFpDbgMemLocation; Tmp: TFpValueConstAddress; Size: TFpDbgValueSize; begin Result := nil; ti := FTypeSymbol.TypeInfo; addr := DerefAddress; if not IsTargetAddr(addr) then begin SetLastError(CreateErrorWithPos(fpErrCannotDeref_p, [ValueToExprText(FValue, MAX_ERR_EXPR_QUOTE_LEN)] )); exit; end; {$PUSH}{$R-}{$Q-} // TODO: check overflow if (ti <> nil) and (AIndex <> 0) then begin // Only test for hardcoded size. TODO: dwarf 3 could have variable size, but for char that is not expected // TODO: Size of member[0] ? if not ti.ReadSize(nil, Size) then begin SetLastError(CreateError(fpErrAnyError, ['Can index element of unknown size'])); exit; end; AIndex := AIndex * SizeToFullBytes(Size); end; addr.Address := addr.Address + AIndex; {$POP} Tmp := TFpValueConstAddress.Create(addr); if ti <> nil then begin Result := ti.TypeCastValue(Tmp); if Result is TFpValueDwarfBase then TFpValueDwarfBase(Result).Context := Context; Tmp.ReleaseReference; end else Result := Tmp; end; constructor TFpPasParserValueCastToPointer.Create(AValue: TFpValue; ATypeInfo: TFpSymbol; AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String); begin inherited Create(AContext, AnExprPos, AnExprText); 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 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: TFpSymbol; begin if FTypeSymbol = nil then begin FTypeSymbol := TPasParserSymbolPointer.Create(FSourceTypeSymbol, FContext, FExprPos, FExprText, FRefLevel); {$IFDEF WITH_REFCOUNT_DEBUG}FTypeSymbol.DbgRenameReference(@FSourceTypeSymbol, 'TPasParserSymbolValueMakeReftype'){$ENDIF}; end; Result := FTypeSymbol; end; constructor TFpPasParserValueMakeReftype.Create(ATypeInfo: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart); begin inherited Create(AnExpressionPart); 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: TFpValue): TFpValue; begin Result := DbgSymbol.TypeCastValue(ADataVal); if Result is TFpValueDwarfBase then TFpValueDwarfBase(Result).Context := Context; end; { TPasParserDerefPointerSymbolValue } function TFpPasParserValueDerefPointer.DebugText(AIndent: String): String; begin Result := inherited DebugText(AIndent) + AIndent + '-Value= ' + DbgsResultValue(FValue, AIndent + ' ') + LineEnding; end; function TFpPasParserValueDerefPointer.GetFieldFlags: TFpValueFieldFlags; var t: TFpSymbol; 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.DerefAddress; if IsValidLoc(Result) then begin SetLastError(Context.LastMemError); exit; end; 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.DoGetSize(out ASize: TFpDbgValueSize ): Boolean; var t: TFpSymbol; begin t := FValue.TypeInfo; if t <> nil then t := t.TypeInfo; if t <> nil then t.ReadSize(nil, ASize) // TODO: create a value object for the deref else Result := inherited DoGetSize(ASize); end; function TFpPasParserValueDerefPointer.GetAsCardinal: QWord; var m: TFpDbgMemManager; Addr: TFpDbgMemLocation; Ctx: TFpDbgLocationContext; 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 Context.MemModel.IsReadableLocation(Addr) then exit; FCardinal := LocToAddrOrNil(Ctx.ReadAddress(Addr, SizeVal(Ctx.SizeOfAddress))); Result := FCardinal; end; function TFpPasParserValueDerefPointer.GetTypeInfo: TFpSymbol; var t: TFpSymbol; 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: TFpValue; AnExpressionPart: TFpPascalExpressionPart); begin Create(AValue, AnExpressionPart, 0); end; constructor TFpPasParserValueDerefPointer.Create(AValue: TFpValue; AnExpressionPart: TFpPascalExpressionPart; AOffset: Int64); begin inherited Create(AnExpressionPart); 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: TFpValue; 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: TFpValueFieldFlags; begin Result := [svfOrdinal, svfCardinal, svfSizeOfPointer, svfDataAddress]; if FValue.Kind in [skChar] then Result := Result + FValue.FieldFlags * [svfString, svfWideString]; 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: TFpSymbol; begin Result := FTypeInfo; if Result <> nil then exit; if FValue.TypeInfo = nil then exit; FTypeInfo := TPasParserSymbolPointer.Create(FValue.TypeInfo, FContext, FExprPos, FExprText, 1); {$IFDEF WITH_REFCOUNT_DEBUG}FTypeInfo.DbgRenameReference(@FTypeInfo, 'TPasParserAddressOfSymbolValue');{$ENDIF} Result := FTypeInfo; end; function TFpPasParserValueAddressOf.GetDerefAddress: TFpDbgMemLocation; begin Result := FValue.Address; end; function TFpPasParserValueAddressOf.GetMember(AIndex: Int64): TFpValue; var ti: TFpSymbol; addr: TFpDbgMemLocation; Tmp: TFpValueConstAddress; Size: TFpDbgValueSize; begin if (AIndex = 0) or (FValue = nil) then begin Result := FValue; if Result <> nil then Result.AddReference; 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) and (AIndex <> 0) then begin // Only test for hardcoded size. TODO: dwarf 3 could have variable size, but for char that is not expected // TODO: Size of member[0] ? if not ti.ReadSize(nil, Size) then begin SetLastError(CreateError(fpErrAnyError, ['Can index element of unknown size'])); exit; end; AIndex := AIndex * SizeToFullBytes(Size); end; addr.Address := addr.Address + AIndex; {$POP} Tmp := TFpValueConstAddress.Create(addr); if ti <> nil then begin Result := ti.TypeCastValue(Tmp); if Result is TFpValueDwarfBase then TFpValueDwarfBase(Result).Context := Context; Tmp.ReleaseReference; end else Result := Tmp; end; function TFpPasParserValueAddressOf.GetAsString: AnsiString; var a: TFpDbgMemLocation; WResult: WideString; begin a := FValue.Address; if (FValue.Kind = skChar) and IsTargetNotNil(a) then begin if (FValue.DataSize = 1) and Context.MemManager.ReadPChar(a, 0, Result) then exit; if (FValue.DataSize = 2) and Context.MemManager.ReadPWChar(a, 0, WResult) then exit(WResult); end; //if (FValue.Kind = skChar) and IsTargetNotNil(a) and // Context.MemManager.ReadPChar(a, 0, Result) //then // exit; // //if (FValue.Kind = skWideString) and IsTargetNotNil(a) and // Context.MemManager.ReadPWChar(a, 0, WResult) //then // exit(WResult); Result := FValue.AsString; if IsError(FValue.LastError) then SetLastError(FValue.LastError); end; function TFpPasParserValueAddressOf.GetAsWideString: WideString; var AResult: AnsiString; a: TFpDbgMemLocation; begin a := FValue.Address; if (FValue.Kind = skChar) and IsTargetNotNil(a) then begin if (FValue.DataSize = 1) and Context.MemManager.ReadPChar(a, 0, AResult) then exit(AResult); if (FValue.DataSize = 2) and Context.MemManager.ReadPWChar(a, 0, Result) then exit; end; Result := FValue.AsWideString; if IsError(FValue.LastError) then SetLastError(FValue.LastError); end; constructor TFpPasParserValueAddressOf.Create(AValue: TFpValue; AnExpressionPart: TFpPascalExpressionPart); begin inherited Create(AnExpressionPart); FValue := AValue; FValue.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserAddressOfSymbolValue'){$ENDIF}; end; destructor TFpPasParserValueAddressOf.Destroy; begin inherited Destroy; FValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FValue, 'TPasParserAddressOfSymbolValue'){$ENDIF}; FTypeInfo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FTypeInfo, 'TPasParserAddressOfSymbolValue'){$ENDIF}; end; { TFpValueFlatteArray } function TFpValueFlatteArray.GetOrdHighBound: Int64; begin Result := FList.Count - 1; end; constructor TFpValueFlatteArray.Create(ALowBound: Integer); begin inherited Create(ALowBound); FList := TRefCntObjList.Create; Flags := Flags + [vfArrayUpperBoundLimit]; end; destructor TFpValueFlatteArray.Destroy; begin FList.Free; inherited Destroy; end; function TFpValueFlatteArray.GetMember(AIndex: Int64): TFpValue; begin if AIndex >= FList.Count then exit(nil); Result := TFpValue(FList[AIndex]); Result.AddReference; end; function TFpValueFlatteArray.GetMemberCount: Integer; begin Result := FList.Count; end; { TFpPascalExpressionCacheFlattenKey } class operator TFpPascalExpressionCacheFlattenKey. = (a, b: TFpPascalExpressionCacheFlattenKey ): boolean; begin Result := (a.CtxThread = b.CtxThread) and (a.CtxStack = b.CtxStack) and (a.Flags = b.Flags) and (a.ExpandArrayDepth = b.ExpandArrayDepth) and (a.Key = b.Key); end; class operator TFpPascalExpressionCacheFlattenKey.<(a, b: TFpPascalExpressionCacheFlattenKey ): boolean; begin raise Exception.Create('not supported'); result := false; end; class operator TFpPascalExpressionCacheFlattenKey.>(a, b: TFpPascalExpressionCacheFlattenKey ): boolean; begin raise Exception.Create('not supported'); result := false; end; { TFpPascalExpressionCacheFlatten } function TFpPascalExpressionCacheFlatten.DoKeyPtrComp(Key1, Key2: Pointer): Integer; begin if PFpPascalExpressionCacheFlattenKey(Key1)^ = PFpPascalExpressionCacheFlattenKey(Key2)^ then Result := 0 else Result := -1; // no sorting needed end; procedure TFpPascalExpressionCacheFlatten.Deref(Item: Pointer); begin Finalize(TFpPascalExpressionCacheFlattenKey(Item^)); PFpValueFlatteArray(Pointer(PByte(Item)+KeySize))^.ReleaseReference; end; constructor TFpPascalExpressionCacheFlatten.Create; begin inherited Create; OnKeyPtrCompare := @DoKeyPtrComp; end; function TFpPascalExpressionCacheFlatten.Add(const AKey: TFpPascalExpressionCacheFlattenKey; const AData: TFpValueFlatteArray): Integer; begin while Count >= 5 do Delete(0); AData.AddReference; Result := inherited Add(AKey, AData); end; function TFpPascalExpressionCacheFlatten.Replace(const AKey: TFpPascalExpressionCacheFlattenKey; const AData: TFpValueFlatteArray): Integer; var i: Integer; begin i := IndexOf(AKey); if i >= 0 then Delete(i); Result := Add(AKey, AData); end; { TAddrSeenList } function TAddrSeenList.DoKeyPtrComp(Key1, Key2: Pointer): Integer; begin if PFpDbgMemLocation(Key1)^ = PFpDbgMemLocation(Key2)^ then Result := 0 else Result := -1; // no sorting needed end; constructor TAddrSeenList.Create; begin inherited Create; OnKeyPtrCompare := @DoKeyPtrComp; end; { TFpPascalExpressionPartOperatorColonAsSeparator } procedure TFpPascalExpressionPartOperatorColonAsSeparator.Init; begin FPrecedence := PRECEDENCE_SEPARATOR_COLON; inherited Init; end; function TFpPascalExpressionPartOperatorColonAsSeparator.DoGetResultValue: TFpValue; begin assert(False, 'TFpPascalExpressionPartOperatorColonAsSeparator.DoGetResultValue: False'); Result := nil; end; function TFpPascalExpressionPartOperatorColonAsSeparator.IsClosed: boolean; begin // Colon separators should only exist in intrinsics Result := (Parent <> nil) and (Parent is TFpPascalExpressionPartBracket) and (Parent.IsClosed); end; { TPasParserSymbolArrayDeIndex } function TPasParserSymbolArrayDeIndex.GetNestedSymbolCount: Integer; begin Result := (inherited GetNestedSymbolCount) - 1; end; function TPasParserSymbolArrayDeIndex.GetNestedSymbol(AIndex: Int64): TFpSymbol; begin Result := inherited GetNestedSymbol(AIndex + 1); end; constructor TPasParserSymbolArrayDeIndex.Create(const AnArray: TFpSymbol); 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 if FPointerLevels = 0 then begin SetTypeInfo(FPointedTo); exit; end; assert(FPointerLevels > 1, 'TPasParserSymbolPointer.TypeInfoNeeded: FPointerLevels > 1'); t := TPasParserSymbolPointer.Create(FPointedTo, FContext, FExprPos, FExprText, FPointerLevels-1); SetTypeInfo(t); t.ReleaseReference; end; function TPasParserSymbolPointer.DoReadSize(const AValueObj: TFpValue; out ASize: TFpDbgValueSize): Boolean; begin ASize := SizeVal(FContext.SizeOfAddress); Result := True; end; constructor TPasParserSymbolPointer.Create(const APointedTo: TFpSymbol; AContext: TFpDbgSimpleLocationContext; AnExprPos: Integer; AnExprText: String; APointerLevels: Integer); begin FContext := AContext; FExprPos := AnExprPos; FExprText := AnExprText; inherited Create(''); 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: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart; APointerLevels: Integer); begin Create(APointedTo, AnExpressionPart.ExpressionData.Scope.LocationContext, AnExpressionPart.GetPos, AnExpressionPart.GetText(MAX_ERR_EXPR_QUOTE_LEN), APointerLevels ); end; constructor TPasParserSymbolPointer.Create(const APointedTo: TFpSymbol; AnExpressionPart: TFpPascalExpressionPart); begin Create(APointedTo, AnExpressionPart, 1); end; destructor TPasParserSymbolPointer.Destroy; begin FPointedTo.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(FPointedTo, 'TPasParserSymbolPointer'){$ENDIF}; inherited Destroy; end; function TPasParserSymbolPointer.TypeCastValue(AValue: TFpValue): TFpValue; begin Result := TFpPasParserValueCastToPointer.Create(AValue, Self, FContext, FExprPos, FExprText ); end; { TFpPascalExpressionPartBracketIndex } procedure TFpPascalExpressionPartBracketIndex.Init; begin FPrecedence := PRECEDENCE_ARRAY_IDX; inherited Init; end; function TFpPascalExpressionPartBracketIndex.DoGetResultValue: TFpValue; var TmpVal, TmpVal2, TmpIndex, AutoDereVal: TFpValue; i: Integer; Offs, Len: Int64; ti: TFpSymbol; IsPChar: Boolean; v: String; w: WideString; a: TFpDbgMemLocation; begin Result := nil; assert(Count >= 2, 'TFpPascalExpressionPartBracketIndex.DoGetResultValue: Count >= 2'); if Count < 2 then begin SetError(fpErrPasParserMissingIndexExpression, [GetFullText(MAX_ERR_EXPR_QUOTE_LEN), GetPos]); exit; end; 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; if ExpressionData.AutoDeref and (TmpVal.Kind = skPointer) and (TmpVal.TypeInfo <> nil) and (TmpVal.TypeInfo.TypeInfo <> nil) and (TmpVal.TypeInfo.TypeInfo.Kind in [skString, skAnsiString, skWideString, skArray]) then begin // Copy from TFpPascalExpressionPartOperatorDeRef.DoGetResultValue if (svfDataAddress in TmpVal.FieldFlags) and (IsReadableLoc(TmpVal.DerefAddress)) and // TODO, what if Not readable addr (TmpVal.TypeInfo <> nil) //and (TmpVal.TypeInfo.TypeInfo <> nil) then begin AutoDereVal := TmpVal.Member[0]; TmpVal.ReleaseReference; TmpVal := AutoDereVal; end; if (TmpVal = nil) then begin SetErrorWithPos(fpErrCannotDeref_p, [Items[0].GetText(MAX_ERR_EXPR_QUOTE_LEN)]); exit; end; 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(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateErrorWithPos(fpErrExpectedOrdinalVal_p, [Items[i].GetFullText(MAX_ERR_EXPR_QUOTE_LEN)], Items[i].GetPos) ); TmpVal.ReleaseReference; exit; end; 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(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateErrorWithPos(fpErrExpectedOrdinalVal_p, [Items[i].GetFullText(MAX_ERR_EXPR_QUOTE_LEN)], Items[i].GetPos) ); 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) and (not(TmpVal is TFpPasParserValueAddressOf)) and (not(TmpVal is TFpPasParserValueCastToPointer)) and (not(TmpVal is TFpPasParserValueMakeReftype)); if IsPChar then ExpressionData.FHasPCharIndexAccess := True; if IsPChar and ExpressionData.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(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], TmpVal.LastError ); end; skString, skAnsiString: begin //TODO: move to FpDwarfValue.member ?? if (Count = 2) and (Items[1] is TFpPascalExpressionPartOperatorArraySlice) and TFpPascalExpressionPartOperatorArraySlice(Items[1]).Controller.CanDisableSlice then begin TFpPascalExpressionPartOperatorArraySlice(Items[1]).Controller.DisableSlice := True; Offs := TFpPascalExpressionPartOperatorArraySlice(Items[1]).StartValue; Len := TFpPascalExpressionPartOperatorArraySlice(Items[1]).EndValue - Offs + 1; TmpVal.GetSubString(Offs, Len, v); TmpVal2 := TFpValueConstString.Create(v); end else 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(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateErrorWithPos(fpErrExpectedOrdinalVal_p, [Items[i].GetFullText(MAX_ERR_EXPR_QUOTE_LEN)], Items[i].GetPos) ); TmpVal.ReleaseReference; exit; end; if (not TmpVal.GetSubString(Offs, 1, v)) or (v = '') then begin SetError(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateError(fpErrIndexOutOfRange, [Offs]) ); TmpVal.ReleaseReference; exit; end; TmpVal2 := TFpValueConstChar.Create(v[1]); if TmpVal.TypeInfo <> nil then TFpValueConstChar(TmpVal2).SetType(TmpVal.TypeInfo.TypeInfo); end; a := TmpVal.DataAddress; if IsTargetAddr(a) and IsReadableMem(a) then TFpValueConstWithType(TmpVal2).SetAddress(a + Offs-1); end; skWideString: begin //TODO: move to FpDwarfValue.member ?? if (Count = 2) and (Items[1] is TFpPascalExpressionPartOperatorArraySlice) then begin Offs := TFpPascalExpressionPartOperatorArraySlice(Items[1]).StartValue; Len := TFpPascalExpressionPartOperatorArraySlice(Items[1]).EndValue - Offs + 1; TmpVal.GetSubWideString(Offs, Len, w); TmpVal2 := TFpValueConstString.Create(w); end else 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(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateErrorWithPos(fpErrExpectedOrdinalVal_p, [Items[i].GetFullText(MAX_ERR_EXPR_QUOTE_LEN)], Items[i].GetPos) ); TmpVal.ReleaseReference; exit; end; if (not TmpVal.GetSubWideString(Offs, 1, w)) or (w='') then begin SetError(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateError(fpErrIndexOutOfRange, [Offs]) ); TmpVal.ReleaseReference; exit; end; TmpVal2 := TFpValueConstWideChar.Create(w[1]); end; a := TmpVal.DataAddress; if IsTargetAddr(a) and IsReadableMem(a) then TFpValueConstWideChar(TmpVal2).SetAddress(a + (Offs-1)*2); end; else begin SetError(fpErrPasParserIndexError_Wrapper, [Items[0].GetFullText(MAX_ERR_EXPR_QUOTE_LEN), Items[0].GetPos], CreateError(fpErrTypeNotIndexable, []) ); TmpVal.ReleaseReference; exit; end; end; TmpVal.ReleaseReference; if TmpVal2 = nil then begin SetError('Internal Error, attempting to read array element'); exit; end; 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, [GetFullText(MAX_ERR_EXPR_QUOTE_LEN), GetPos]); end; function TFpPascalExpressionPartBracketIndex.HandleSeparator( ASeparatorType: TSeparatorType; var APart: TFpPascalExpressionPart): Boolean; begin if (not (ASeparatorType = ppstComma)) or IsClosed then begin Result := inherited HandleSeparator(ASeparatorType, APart); exit; end; Result := (Count > FAfterComma) and (Count > 1); // First element is name of array (in front of "[") if Result then begin CheckBeforeSeparator(APart); SetAfterCommaFlag; APart := Self; end; end; procedure TFpPascalExpressionPartBracketIndex.CloseBracket( ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar); var i: Integer; begin inherited CloseBracket(ALastAddedPart, APreviousArraySliceList, AStartChar, AnEndChar); for i := 1 to Count - 1 do Items[i].DoParentIndexBraceClosed(APreviousArraySliceList); end; { TFpPascalExpressionPartBracketSet } function TFpPascalExpressionPartBracketSet.DoGetResultValue: TFpValue; var i: Integer; itm: TFpPascalExpressionPart; m: TFpValue; begin Result := TFpValueConstSet.Create; for i := 0 to Count - 1 do begin itm := Items[i]; m := itm.ResultValue; TFpValueConstSet(Result).AddVal(m); end; end; 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; var APart: TFpPascalExpressionPart): Boolean; begin if (not (ASeparatorType = ppstComma)) or IsClosed then begin Result := inherited HandleSeparator(ASeparatorType, APart); exit; end; Result := (Count > FAfterComma) and (Count > 0); if Result then begin CheckBeforeSeparator(APart); SetAfterCommaFlag; APart := Self; end; 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: TFpValue; var tmp, tmp2, tmpSelf: TFpValue; err: TFpError; Itm0: TFpPascalExpressionPart; ItmMO: TFpPascalExpressionPartOperatorMemberOf absolute Itm0; Params: TFpPascalExpressionPartListForwarder; begin Result := nil; if (Count = 0) then begin SetError(fpErrPasParserInvalidExpression, []); exit; end; Itm0 := Items[0]; if Itm0 is TFpPascalExpressionPartIntrinsicBase then begin Result := TFpPascalExpressionPartIntrinsicBase(Itm0).DoGetResultValue(Self); exit; end; (* If Itm0 is an identifer we could use [fsfIgnoreEnumVals] But then alTop(1) would give "identifer not found", rather than a proper error *) tmp := Itm0.ResultValue; if (tmp = nil) or (not ExpressionData.Valid) then exit; if (tmp.DbgSymbol <> nil) and (tmp.DbgSymbol.Kind in [skFunction, skFunctionRef]) then begin if not Assigned(ExpressionData.OnFunctionCall) then begin SetError('calling functions not allowed'); exit; end; tmpSelf := nil; if (Itm0 is TFpPascalExpressionPartOperatorMemberOf) then begin if ItmMO.Count = 2 then tmpSelf := ItmMO.Items[0].ResultValue; if tmpSelf = nil then begin SetError('internal error evaluating method call'); exit; end; end; err := NoError; Params := TFpPascalExpressionPartListForwarder.Create(Self, 1, Count - 1); try if not ExpressionData.OnFunctionCall(Self, tmp, tmpSelf, Params, Result, err) then begin if not IsError(err) then SetError('unknown error calling function') else ExpressionData.SetError(err); Result := nil; end; finally Params.Free; end; {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; exit; end; 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 // skProcedure is not handled SetError('unknown type or function'); 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 Items[0].AcceptParamAsSeparator(APart, Self, Result) then // Must "Add" APart exit; if (Count > 1) and (not AfterComma) then begin // Todo a,b,c SetError(APart, 'Comma or closing ")" expected: '+GetText+': '); APart.Free; exit; end; Add(APart); Result := APart; Items[0].HandleNewParameterInList(APart, Self); 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; var APart: TFpPascalExpressionPart): Boolean; begin if (not (ASeparatorType = ppstComma)) or IsClosed then begin Result := inherited HandleSeparator(ASeparatorType, APart); exit; end; Result := (Count > FAfterComma) and (Count > 1); // First element is name of function (in front of "(") if Result then begin CheckBeforeSeparator(APart); SetAfterCommaFlag; Items[0].HandleEndOfParameterInList(APart, Self); APart := Self; end; end; procedure TFpPascalExpressionPartBracketArgumentList.CloseBracket( ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar); begin inherited CloseBracket(ALastAddedPart, APreviousArraySliceList, AStartChar, AnEndChar); if ExpressionData.Valid then Items[0].HandleEndOfParameterInList(ALastAddedPart, Self); end; function TFpPascalExpressionPartBracketArgumentList.ReturnsVariant: boolean; var Itm0: TFpPascalExpressionPart; begin Result := inherited ReturnsVariant; if Result then exit; Itm0 := Items[0]; if Itm0 = nil then exit; Result := Itm0.ReturnsVariant; end; function TFpPascalExpressionPartBracketArgumentList.IntrinsicType: TFpIntrinsicFunc; begin Result := ifErrorNotFound; if (Count > 1) and (Items[0] is TFpPascalExpressionPartIntrinsic) then Result := TFpPascalExpressionPartIntrinsic(Items[0]).FIntrinsic; end; { TFpPascalExpressionPartIntrinsicBase } function TFpPascalExpressionPartIntrinsicBase.CheckArgumentCount( AParams: TFpPascalExpressionPartBracketArgumentList; ARequiredCount: Integer; AMaxAccepted: Integer): Boolean; var i: Integer; begin if AMaxAccepted < 0 then Result := AParams.Count - 1 = ARequiredCount else Result := (AParams.Count - 1 >= ARequiredCount) and (AParams.Count - 1 <= AMaxAccepted); if not Result then begin SetError('wrong argument count'); exit; end; for i := 1 to ARequiredCount do if (AParams.Items[i] = nil) then begin Result := False; SetError('wrong argument count'); exit; end; end; function TFpPascalExpressionPartIntrinsicBase.GetArg( AParams: TFpPascalExpressionPartBracketArgumentList; ANum: Integer; out AValue: TFpValue; AnErr: String): Boolean; begin AValue := nil; Result := ANum < AParams.Count; if not Result then begin if AnErr <> '' then SetError(AnErr); exit; end; AValue := AParams.Items[ANum].ResultValue; Result := (AValue <> nil) and (not IsError(ExpressionData.Error)) and (not IsError(AValue.LastError)); if not Result then begin if AnErr <> '' then SetError(AnErr); end; end; function TFpPascalExpressionPartIntrinsicBase.DoGetResultValue: TFpValue; begin SetError('wrong argument count'); Result := nil; end; function TFpPascalExpressionPartIntrinsicBase.DoGetResultValue( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; begin SetError('internal error'); Result := nil; 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: TFpValue; 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; function TFpPascalExpressionPartBracketSubExpression.HandleSeparator( ASeparatorType: TSeparatorType; var APart: TFpPascalExpressionPart): Boolean; begin if IsClosed then Result := inherited HandleSeparator(ASeparatorType, APart) else Result := False; end; procedure TFpPascalExpressionPartBracketSubExpression.CloseBracket( ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar); begin if (Count <> 1) then SetError('Empty brackets') else inherited CloseBracket(ALastAddedPart, APreviousArraySliceList, AStartChar, AnEndChar); end; { TFpPascalExpressionPartIdentifier } function TFpPascalExpressionPartIdentifier.DoGetIsTypeCast: Boolean; begin Result := (ResultValue <> nil) and (ResultValue.DbgSymbol <> nil) and (ResultValue.DbgSymbol.SymbolType = stType); end; function TFpPascalExpressionPartIdentifier.DoGetResultValue: TFpValue; var s: String; tmp: TFpValueConstAddress; begin s := GetText; if FOnGetSymbol <> nil then Result := FOnGetSymbol(Self, s) else Result := ExpressionData.GetDbgSymbolForIdentifier(s); if Result = nil then begin if CompareText(s, 'nil') = 0 then begin tmp := TFpValueConstAddress.Create(NilLoc); Result := TFpPasParserValueAddressOf.Create(tmp, Self); tmp.ReleaseReference; {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end else if CompareText(s, 'true') = 0 then begin Result := TFpValueConstBool.Create(True); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end else if CompareText(s, 'false') = 0 then begin Result := TFpValueConstBool.Create(False); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end else begin SetErrorWithPos(fpErrSymbolNotFound_p, [GetText]); exit; end; end {$IFDEF WITH_REFCOUNT_DEBUG} else Result.DbgRenameReference(nil, 'DoGetResultValue') {$ENDIF} ; end; procedure TFpPascalExpressionPartIdentifier.Assign(ASourcePart: TFpPascalExpressionPart); var IdentSourcePart: TFpPascalExpressionPartIdentifier absolute ASourcePart; p: TFpPascalExpressionPart; begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartIdentifier then begin if IdentSourcePart.FOnGetSymbol <> nil then begin p := FindCopiedInParents(ASourcePart, TFpPascalExpressionPart(TMethod(IdentSourcePart.FOnGetSymbol).Data), [fipIncludeBracketFunction]); if p <> nil then FOnGetSymbol := @TFpPascalExpressionPartIntrinsic(p).DoGetMemberForFlattenExpr; end; end; end; procedure TFpPascalExpressionPartIdentifier.ResetEvaluation; begin if (FResultValue <> nil) and (FOnGetSymbol = nil) then FResultValue.Reset else inherited ResetEvaluation; 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; { TFpPascalExpressionPartCpuRegister } function TFpPascalExpressionPartCpuRegister.DoGetResultValue: TFpValue; begin Result := ExpressionData.GetRegisterValue(GetText); {$IFDEF WITH_REFCOUNT_DEBUG} if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue') {$ENDIF} end; { TFpPascalExpressionPartIntrinsic } function TFpPascalExpressionPartIntrinsic.DoGetMemberForFlattenExpr( APart: TFpPascalExpressionPart; AnIdent: String): TFpValue; begin if FFlattenCurrentVal = nil then exit(nil); Result := FFlattenCurrentVal.MemberByName[AnIdent]; if Result = nil then begin SetError(fpErrNoMemberWithName, [AnIdent]); FFlattenMemberNotFound := True; FFlattenMemberName := AnIdent; end; end; function TFpPascalExpressionPartIntrinsic.DoTry(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Expr: TFpPascalExpressionPart; HighIdx, i: Integer; ff: TFpValueFieldFlags; begin Result := nil; if IsError(ExpressionData.Error) then exit; if not CheckArgumentCount(AParams, 2, 999) then exit; HighIdx := AParams.Count-1; for i := 1 to HighIdx-1 do begin Expr := AParams.Items[i]; Result := Expr.GetResultValue; if (Result <> nil) and (not IsError(ExpressionData.Error)) then begin ff := Result.FieldFlags; if ( (not (svfAddress in ff)) or (IsValidLoc(Result.Address)) ) then begin Result.AddReference; exit; end; end; Expr.ResetEvaluationRecursive; ExpressionData.ClearError; end; Expr := AParams.Items[HighIdx]; Result := Expr.GetResultValue; Result.AddReference; end; function TFpPascalExpressionPartIntrinsic.DoTryN( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Expr: TFpPascalExpressionPart; HighIdx, i: Integer; ff: TFpValueFieldFlags; deref: TFpDbgMemLocation; begin Result := nil; if IsError(ExpressionData.Error) then exit; if not CheckArgumentCount(AParams, 2, 999) then exit; HighIdx := AParams.Count-1; for i := 1 to HighIdx-1 do begin Expr := AParams.Items[i]; Result := Expr.GetResultValue; if (Result <> nil) and (not IsError(ExpressionData.Error)) then begin ff := Result.FieldFlags; deref := Result.DerefAddress; if ( (not (svfAddress in ff)) or (IsReadableLoc(Result.Address)) ) and ( (not (svfDataAddress in ff)) or (IsReadableLoc(Result.DataAddress)) ) and // if deref returned invalid, then its not a pointer ( (not IsValidLoc(deref)) or (IsReadableLoc(deref)) ) then begin Result.AddReference; exit; end; end; Expr.ResetEvaluationRecursive; ExpressionData.ClearError; end; Expr := AParams.Items[HighIdx]; Result := Expr.GetResultValue; Result.AddReference; end; function TFpPascalExpressionPartIntrinsic.DoObj(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Res: TFpValueConstStruct absolute Result; i: Integer; p: TFpPascalExpressionPart; p_c: TFpPascalExpressionPartOperatorColonAsSeparator absolute p; rv: TFpValue; begin Result := TFpValueConstStruct.Create; for i := 1 to AParams.Count - 1 do begin p := AParams.Items[i]; if not (p is TFpPascalExpressionPartOperatorColonAsSeparator) then begin ReleaseRefAndNil(Result); exit; end; rv := p_c.Items[1].ResultValue; if (rv = nil) or IsError(ExpressionData.Error) then begin if IsError(ExpressionData.Error) then rv := TFpValueConstError.Create(ExpressionData.Error) else rv := TFpValueConstError.Create(CreateError(fpErrAnyError, ['internal error'])); ExpressionData.ClearError; Res.AddMember(p_c.Items[0].GetText, rv); rv.ReleaseReference; end else Res.AddMember(p_c.Items[0].GetText, rv); p_c.Items[1].ResetEvaluationRecursive; end; end; function TFpPascalExpressionPartIntrinsic.DoOrd(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if Arg.FieldFlags * [svfOrdinal, svfCardinal] <> [] then Result := TFpValueConstNumber.Create(Arg.AsCardinal, False) else if Arg.FieldFlags * [svfInteger] <> [] then Result := TFpValueConstNumber.Create(Arg.AsInteger, True) else SetError('Can''t get ordinal value of argument'); end; function TFpPascalExpressionPartIntrinsic.DoLength( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg: TFpValue; ResLen: Integer; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; ResLen := 0; case Arg.Kind of skChar: ResLen := 1; skString, skAnsiString, skWideString, skArray: ResLen := Arg.MemberCount; otherwise begin SetError('argument not supported'); exit; end; end; Result := TFpValueConstNumber.Create(ResLen, True) end; function TFpPascalExpressionPartIntrinsic.DoChildClass( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var CastName: String; NewResult, Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; Result := Arg; Result.AddReference; if (Result.Kind <> skClass) or (Result.AsCardinal = 0) then exit; if not Result.GetInstanceClassName(CastName) then exit; FChildClassCastType.ReleaseReference; FChildClassCastType := ExpressionData.GetDbgSymbolForIdentifier(CastName, [fsfIgnoreEnumVals]); if (FChildClassCastType = nil) or (FChildClassCastType.DbgSymbol = nil) or (FChildClassCastType.DbgSymbol.SymbolType <> stType) or (FChildClassCastType.DbgSymbol.Kind <> skClass) then begin ReleaseRefAndNil(FChildClassCastType); exit; end; // FChildClassCastType.DbgSymbol is part of NewResult, but not refcounted; NewResult := FChildClassCastType.GetTypeCastedValue(Result); if NewResult <> nil then begin Result.ReleaseReference; Result := NewResult; end; end; function TFpPascalExpressionPartIntrinsic.DoFlatten( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Res: TFpValueFlatteArray absolute Result; Seen: TAddrSeenList; HighParam: integer; Flags: TFpPascalExpressionFlattenFlags; MaxCnt, ExpandArrayDepth: integer; TpSym: TFpSymbol; CacheKey: TFpPascalExpressionCacheFlattenKey; SkipCache: Boolean; function FlattenRecurse(ACurrentVal: TFpValue; ACurDepth: integer; ACurKey: String): boolean; forward; function FlattenArray(ACurrentVal: TFpValue; AMapExpr: TFpPascalExpressionPart; ACurDepth, ACurKeyIdx: integer; ACurKey: String; AnExpandDepth: integer): boolean; forward; function InternalAdd(ACurrentVal: TFpValue; ACurDepth, ACurKeyIdx: integer; ACurKey: String): Integer; var TmpVal: TFpValueConstStruct; TmpVal2: TFpValue; begin if ACurrentVal is TFpPasParserValueSlicedArray then SkipCache := True; if iffObj1 in Flags then begin TmpVal := TFpValueConstStruct.Create; TmpVal2 := TFpValueConstNumber.Create(ACurDepth, False); TmpVal.AddMember('d', TmpVal2); TmpVal2.ReleaseReference; TmpVal2 := TFpValueConstString.Create(ACurKey); TmpVal.AddMember('k', TmpVal2); TmpVal2.ReleaseReference; TmpVal.AddMember('v', ACurrentVal); Result := Res.FList.Add(TmpVal); TmpVal.ReleaseReference; end else if iffObj2 in Flags then begin TmpVal := TFpValueConstStruct.Create; TmpVal2 := TFpValueConstNumber.Create(ACurDepth, False); TmpVal.AddMember('d', TmpVal2); TmpVal2.ReleaseReference; TmpVal2 := TFpValueConstNumber.Create(QWord(ACurKeyIdx), True); TmpVal.AddMember('k', TmpVal2); TmpVal2.ReleaseReference; TmpVal.AddMember('v', ACurrentVal); Result := Res.FList.Add(TmpVal); TmpVal.ReleaseReference; end else if Flags * [iffObj3, iffObj4] <> [] then begin TmpVal := TFpValueConstStruct.Create; TmpVal2 := TFpValueConstString.Create(ACurKey); TmpVal.AddMember('k', TmpVal2); TmpVal2.ReleaseReference; TmpVal.AddMember('v', ACurrentVal); Result := Res.FList.Add(TmpVal); TmpVal.ReleaseReference; end else Result := Res.FList.Add(ACurrentVal); end; procedure AddErrToList(AnErr: TFpError; ACurDepth, ACurKeyIdx: integer; ACurKey: String); var E: TFpValueConstError; begin E := TFpValueConstError.Create(AnErr); InternalAdd(E, ACurDepth, ACurKeyIdx, ACurKey); E.ReleaseReference end; function EvalExression(AnExpr: TFpPascalExpressionPart; ACurrentVal, AnOrigVal: TFpValue; ShowMemberNotFoundErr: boolean; ACurDepth, ACurKeyIdx: integer; ACurKey: String): TFpValue; var s: String; Err: TFpError; begin Result := nil; Err := NoError; if AnExpr is TFpPascalExpressionPartIdentifier then begin FFlattenMemberNotFound := not(ACurrentVal.Kind in [skClass, skInterface, skRecord, skObject]); if not FFlattenMemberNotFound then begin FFlattenMemberName := AnExpr.GetText; Result := ACurrentVal.MemberByName[FFlattenMemberName]; FFlattenMemberNotFound := (Result = nil) and ShowMemberNotFoundErr; end; end else begin FFlattenCurrentVal := ACurrentVal; FFlattenCurrentValOrig := AnOrigVal; // for :_ FFlattenMemberNotFound := False; FFlattenMemberName := ''; AnExpr.ResetEvaluationRecursive; Result := AnExpr.GetResultValue; if Result <> nil then Result.AddReference; if not ShowMemberNotFoundErr then FFlattenMemberNotFound := False; // show general error instead Err := ExpressionData.Error; //AnExpr.ResetEvaluationRecursive; ExpressionData.ClearError; if (not FFlattenMemberNotFound) and IsError(Err) then begin if (iffShowErrAny in Flags) then AddErrToList(CreateError(fpErrAnyError, ['Failed eval for member: ' + FFlattenMemberName + ' '+ErrorHandler.ErrorAsString(Err)]), ACurDepth, ACurKeyIdx, ACurKey); ReleaseRefAndNil(Result); exit end; if (not FFlattenMemberNotFound) and AnExpr.ReturnsVariant then Res.Flags := Res.Flags + [vfArrayOfVariant]; end; if FFlattenMemberNotFound then begin if (iffShowNoMember in Flags) then AddErrToList(CreateError(fpErrAnyError, ['Member not found: ' + FFlattenMemberName]), ACurDepth, ACurKeyIdx, ACurKey); ReleaseRefAndNil(Result); exit; end; if Result = nil then begin if (iffShowErrAny in Flags) then begin s := ''; if IsError(Err) then s := ErrorHandler.ErrorAsString(Err); AddErrToList(CreateError(fpErrAnyError, ['Internal error for member: ' + FFlattenMemberName + ' '+s]), ACurDepth, ACurKeyIdx, ACurKey); end; exit; end; end; function AddFlatValue(ACurrentVal: TFpValue; AMapExpr: TFpPascalExpressionPart; ACurDepth, ACurKeyIdx: integer; ACurKey: String; AnExpandDepth: integer): boolean; var s, ResIdx, SeenIdx, ValIdx: Integer; PrevVal, TmpAutoDereVal, DisplayVal, OrigVal: TFpValue; DA: TFpDbgMemLocation; DoExpArray, HasDtAddr: Boolean; begin Result := True; if ACurrentVal = nil then begin if (iffShowErrAny in Flags) then AddErrToList(CreateError(fpErrAnyError, ['Internal error for member: ' + FFlattenMemberName + ' '+ErrorHandler.ErrorAsString(ExpressionData.Error)]), ACurDepth, ACurKeyIdx, ACurKey); exit; end; OrigVal := ACurrentVal; OrigVal.AddReference; DisplayVal := nil; ResIdx := -1; try if (iffDerefPtr in Flags) and (ACurrentVal.Kind = skPointer) and (ACurrentVal.TypeInfo <> nil) and (ACurrentVal.TypeInfo.TypeInfo <> nil) and (ACurrentVal.TypeInfo.TypeInfo.Kind in [skClass, skInterface, skRecord, skObject]) then begin if (svfDataAddress in ACurrentVal.FieldFlags) and (IsReadableLoc(ACurrentVal.DerefAddress)) and // TODO, what if Not readable addr (ACurrentVal.TypeInfo <> nil) //and (ACurrentVal.TypeInfo.TypeInfo <> nil) then begin TmpAutoDereVal := ACurrentVal.Member[0]; if TmpAutoDereVal <> nil then begin ACurrentVal.ReleaseReference; ACurrentVal := TmpAutoDereVal; end; end; end; DoExpArray := (AnExpandDepth > 0) and (ACurrentVal.Kind = skArray); HasDtAddr := (svfDataAddress in ACurrentVal.FieldFlags); DA := ACurrentVal.DataAddress; if IsReadableLoc(DA) then begin SeenIdx := Seen.IndexOf(DA); if (SeenIdx >= 0) then begin ValIdx := Seen.Data[SeenIdx]; if (not DoExpArray) and (not (ACurrentVal.Kind in [skClass, skInterface])) then begin PrevVal := TFpValue(Res.FList[ValIdx]); if (ACurrentVal.TypeInfo = nil) or (PrevVal.TypeInfo = nil) or (not ACurrentVal.TypeInfo.IsEqual(PrevVal.TypeInfo)) then SeenIdx := -1; end; if (SeenIdx >= 0) then begin if (iffShowRecurse in Flags) and (ValIdx >= 0) then begin if DoExpArray then AddErrToList(CreateError(fpErrAnyError, [Format('Recursion detected for array at member: %s (At Index %d)', [FFlattenMemberName, ValIdx])]), ACurDepth, ACurKeyIdx, ACurKey) else AddErrToList(CreateError(fpErrAnyError, [Format('Recursion detected for member: %s (At Index %d)', [FFlattenMemberName, ValIdx])]), ACurDepth, ACurKeyIdx, ACurKey); end else if (iffShowSeen in Flags) then begin if ValIdx < 0 then ValIdx := -(ValIdx + 1); if DoExpArray then AddErrToList(CreateError(fpErrAnyError, [Format('Array for member already shown: %s (At Index %d)', [FFlattenMemberName, ValIdx])]), ACurDepth, ACurKeyIdx, ACurKey) else AddErrToList(CreateError(fpErrAnyError, [Format('Member already shown: %s (At Index %d)', [FFlattenMemberName, ValIdx])]), ACurDepth, ACurKeyIdx, ACurKey); end; ReleaseRefAndNil(ACurrentVal); exit; end; end; end; if ( (not DoExpArray) or (HasDtAddr and not IsReadableLoc(DA)) ) and ( (iffShowNil in Flags) or (not IsNilLoc(DA)) ) then begin // not an array, or array can not be expanded => show value if (AMapExpr = nil) then begin DisplayVal := ACurrentVal; DisplayVal.AddReference; end else DisplayVal := EvalExression(AMapExpr, ACurrentVal, OrigVal, False, ACurDepth, ACurKeyIdx, ACurKey); if (DisplayVal <> nil) then begin ResIdx := InternalAdd(DisplayVal, ACurDepth, ACurKeyIdx, ACurKey); if (DisplayVal.TypeInfo = nil) or (not DisplayVal.TypeInfo.IsEqual(TpSym)) or (DisplayVal.Flags * [vfArrayOfVariant, vfVariant] <> []) then Res.Flags := Res.Flags + [vfArrayOfVariant]; end; end; if IsNilLoc(DA) or ( (not IsReadableLoc(DA)) and ((not DoExpArray) or HasDtAddr) ) then begin ReleaseRefAndNil(ACurrentVal); exit; end; if DoExpArray then begin Result := FlattenArray(ACurrentVal, AMapExpr, ACurDepth + 1, ACurKeyIdx, ACurKey, AnExpandDepth); end else begin s := Seen.Add(DA, ResIdx); Result := FlattenRecurse(ACurrentVal, ACurDepth+1, ACurKey); if (iffShowSeen in Flags) then Seen.Data[s] := -1-ResIdx else Seen.Delete(s); end; ReleaseRefAndNil(ACurrentVal); finally DisplayVal.ReleaseReference; OrigVal.ReleaseReference; end; end; function FlattenArray(ACurrentVal: TFpValue; AMapExpr: TFpPascalExpressionPart; ACurDepth, ACurKeyIdx: integer; ACurKey: String; AnExpandDepth: integer): boolean; var Idx, Cnt: Integer; TmpNew: TFpValue; LBnd: Int64; begin // Seen.Add(DA, -2 - FList.Count); // array seen LBnd := ACurrentVal.OrdLowBound; Cnt := ACurrentVal.MemberCount; if Cnt > 1 then begin // LOCK the ExpressionData end; for Idx := 0 to Cnt - 1 do begin if Res.FList.Count >= MaxCnt then exit(False); TmpNew := ACurrentVal.Member[Idx+LBnd]; // AddFlatValue will release TmpNew Result := AddFlatValue(TmpNew, AMapExpr, ACurDepth, ACurKeyIdx, ACurKey+'['+IntToStr(Idx+LBnd)+']', Max(0, AnExpandDepth-1)); if not Result then exit; end; // UNLOCK Result := True; end; function FlattenRecurse(ACurrentVal: TFpValue; ACurDepth: integer; ACurKey: String): boolean; var i: Integer; OrigVal, AutoDereVal, TmpNew: TFpValue; Expr, MapExpr, TmpExpr: TFpPascalExpressionPart; Expr_as_ColSep: TFpPascalExpressionPartOperatorColonAsSeparator absolute Expr; r: Boolean; NxtKey: String; begin Result := True; if HighParam < 2 then exit; AutoDereVal := nil; OrigVal := ACurrentVal; OrigVal.AddReference; try if ExpressionData.AutoDeref and (ACurrentVal.Kind = skPointer) and (ACurrentVal.TypeInfo <> nil) and (ACurrentVal.TypeInfo.TypeInfo <> nil) and (ACurrentVal.TypeInfo.TypeInfo.Kind in [skClass, skInterface, skRecord, skObject]) then begin if (svfDataAddress in ACurrentVal.FieldFlags) and (IsReadableLoc(ACurrentVal.DerefAddress)) and // TODO, what if Not readable addr (ACurrentVal.TypeInfo <> nil) //and (ACurrentVal.TypeInfo.TypeInfo <> nil) then begin AutoDereVal := ACurrentVal.Member[0]; ACurrentVal := AutoDereVal; end; if (ACurrentVal = nil) then begin //if (iffShowErrAny in Flags) then // AddErrToList(CreateError(fpErrAnyError, ['Can't flatten nil pointer']), ACurDepth, -1, ACurKey); exit; end; end; case ACurrentVal.Kind of skClass, skInterface, skRecord, skObject: begin for i := 2 to HighParam do begin if Res.FList.Count >= MaxCnt then exit(False); Expr := AParams.Items[i]; MapExpr := nil; if Expr is TFpPascalExpressionPartOperatorColonAsSeparator then begin if Expr_as_ColSep.Count <> 2 then begin SetError('Internal erorr'); exit(false); end; MapExpr := Expr_as_ColSep.Items[1]; Expr := Expr_as_ColSep.Items[0]; if MapExpr is TFpPascalExpressionPartConstantNumber then begin TmpNew := MapExpr.ResultValue; if (TmpNew is TFpValueConstNumber) then begin TmpExpr := AParams.Items[1+TmpNew.AsInteger]; if (not (TmpExpr is TFpPascalExpressionPartOperatorColonAsSeparator)) or (TFpPascalExpressionPartOperatorColonAsSeparator(TmpExpr).Count <> 2) then begin SetError('Incorrect reference to map-expression'); exit(false); end; MapExpr := TFpPascalExpressionPartOperatorColonAsSeparator(TmpExpr).Items[1]; if (MapExpr is TFpPascalExpressionPartConstantNumber) and (MapExpr.ResultValue is TFpValueConstNumber) then begin SetError('Incorrect reference to map-expression'); exit(false); end; end; end; end; if (iffObj4 in Flags) and (Length(ACurKey) < 1000) then begin if (ACurKey = '') then NxtKey := IntToStr(i-2) else NxtKey := ACurKey + '.' + IntToStr(i-2); end else begin NxtKey := Expr.GetFullText; if (iffObj3 in Flags) and (ACurKey <> '') and (Length(ACurKey) < 1000) then NxtKey := ACurKey + '.' + NxtKey end; Expr.BeginNeedCopy; TmpNew := EvalExression(Expr, ACurrentVal, OrigVal, True, ACurDepth, i-2, NxtKey); if TmpNew = nil then begin Expr.EndNeedCopy; Continue; end; // AddFlatValue will release TmpNew r := AddFlatValue(TmpNew, MapExpr, ACurDepth, i-2, NxtKey, ExpandArrayDepth); Expr.EndNeedCopy; if not r then exit(False); end; end; //skArray: begin end; else begin //if (iffShowErrAny in Flags) then // AddErrToList(CreateError(fpErrAnyError, ['Can''t flatten value']), ACurDepth, -1, ACurKey); end; end; finally OrigVal.ReleaseReference; AutoDereVal.ReleaseReference; end; Result := True; end; var FirstVal: TFpValue; DA: TFpDbgMemLocation; LastParam, Itm: TFpPascalExpressionPart; OptSet: TFpPascalExpressionPartBracketSet absolute LastParam; i: Integer; OName: String; OVal, CustomMaxCnt, LastParamNeg: Boolean; PParent: TFpPascalExpressionPartContainer; ListCache: TFpPascalExpressionCacheFlatten; begin Result := nil; if not CheckArgumentCount(AParams, 1, 999) then exit; if not GetArg(AParams, 1, FirstVal, 'Value required') then exit; if (FirstVal.Kind <> skArray) and (not CheckArgumentCount(AParams, 2, 999)) then exit; Flags := [iffShowNil, iffShowNoMember, iffShowRecurse, iffShowSeen, iffShowErrAny, iffDerefPtr]; ExpandArrayDepth := 0; MaxCnt := 1000; CustomMaxCnt := False; HighParam := AParams.Count - 1; if HighParam > 0 then begin LastParam := AParams.Items[HighParam]; LastParamNeg := False; if (LastParam is TFpPascalExpressionPartOperatorUnaryPlusMinus) and (TFpPascalExpressionPartOperatorUnaryPlusMinus(LastParam).Count = 1) and (TFpPascalExpressionPartOperatorUnaryPlusMinus(LastParam).Items[0] is TFpPascalExpressionPartBracketSet) then begin // Add or Sub from defaults LastParamNeg := LastParam.GetText = '-'; LastParam := TFpPascalExpressionPartOperatorUnaryPlusMinus(LastParam).Items[0]; end else if LastParam is TFpPascalExpressionPartBracketSet then Flags := []; // NO +/- => Start with empty, if LastParam is TFpPascalExpressionPartBracketSet then begin if (FirstVal.Kind <> skArray) and (not CheckArgumentCount(AParams, 3, 999)) then exit; dec(HighParam); if HighParam < 2 then begin SetError('Not enough parameter'); exit; end; if (HighParam > 2) and (Flags <> []) then Flags := Flags + [iffObj1]; for i := 0 to OptSet.Count - 1 do begin Itm := OptSet.Items[i]; OName := ''; OVal := True; if (Itm is TFpPascalExpressionPartIdentifier) then OName := Itm.GetText else if (Itm is TFpPascalExpressionPartOperatorCompare) and (Itm.GetText = '=') and (TFpPascalExpressionPartOperatorCompare(Itm).Count = 2) and (TFpPascalExpressionPartOperatorCompare(Itm).Items[1].ResultValue <> nil) then begin OName := TFpPascalExpressionPartOperatorCompare(Itm).Items[0].GetText; if LowerCase(OName)= 'max' then begin MaxCnt := TFpPascalExpressionPartOperatorCompare(Itm).Items[1].ResultValue.AsInteger; CustomMaxCnt := True; Continue; end; if LowerCase(OName)= 'array' then begin ExpandArrayDepth := TFpPascalExpressionPartOperatorCompare(Itm).Items[1].ResultValue.AsInteger; Continue; end; OVal := TFpPascalExpressionPartOperatorCompare(Itm).Items[1].ResultValue.AsBool; end; OVal := OVal xor LastParamNeg; case LowerCase(OName) of 'nil': if OVal then include(Flags, iffShowNil) else exclude(Flags, iffShowNil); 'field', 'fld': if OVal then include(Flags, iffShowNoMember) else exclude(Flags, iffShowNoMember); 'loop', 'recurse': if OVal then include(Flags, iffShowRecurse) else exclude(Flags, iffShowRecurse); 'seen', 'dup': if OVal then include(Flags, iffShowSeen) else exclude(Flags, iffShowSeen); 'err', 'error': if OVal then include(Flags, iffShowErrAny) else exclude(Flags, iffShowErrAny); 'array': ExpandArrayDepth := 1; 'ptr', 'deref': if OVal then include(Flags, iffDerefPtr) else exclude(Flags, iffDerefPtr); 'obj': begin Flags := Flags - [iffObj1, iffObj2, iffObj3, iffObj4]; if OVal then include(Flags, iffObj1); end; 'o1', 'obj1': begin if Oval then Flags := Flags - [iffObj1, iffObj2, iffObj3, iffObj4]; if OVal then include(Flags, iffObj1) else exclude(Flags, iffObj1); end; 'o2', 'obj2': begin if Oval then Flags := Flags - [iffObj1, iffObj2, iffObj3, iffObj4]; if OVal then include(Flags, iffObj2) else exclude(Flags, iffObj2); end; 'o3', 'obj3': begin if Oval then Flags := Flags - [iffObj1, iffObj2, iffObj3, iffObj4]; if OVal then include(Flags, iffObj3) else exclude(Flags, iffObj3); end; 'o4', 'obj4': begin if Oval then Flags := Flags - [iffObj1, iffObj2, iffObj3, iffObj4]; if OVal then include(Flags, iffObj4) else exclude(Flags, iffObj4); end; else begin SetError('Unknown flag: '+Itm.GetText); exit; end; end; end; end else if HighParam > 2 then Flags := Flags + [iffObj1]; end; ListCache := nil; SkipCache := False; if (ExpressionData.GlobalCache <> nil) then begin Itm := TopParent; while (not SkipCache) and (Itm is TFpPascalExpressionPartOperatorArraySliceController) do begin SkipCache := TFpPascalExpressionPartOperatorArraySliceController(Itm).SlicePart.FindInParents(Self.Parent); Itm := TFpPascalExpressionPartContainer(Itm).Items[0]; end; end; if (not SkipCache) and (ExpressionData.GlobalCache <> nil) then begin CacheKey.CtxThread := ExpressionData.Scope.LocationContext.ThreadId; CacheKey.CtxStack := ExpressionData.Scope.LocationContext.StackFrame; CacheKey.Flags := Flags; CacheKey.ExpandArrayDepth := ExpandArrayDepth; CacheKey.Key := Parent.GetFullText; i := ExpressionData.GlobalCache.IndexOf(Pointer(TFpPascalExpressionPartIntrinsic)); if i >= 0 then begin ListCache := TFpPascalExpressionCacheFlatten(ExpressionData.GlobalCache.Data[i]); i := ListCache.IndexOf(CacheKey); if i >= 0 then begin Result := ListCache.Data[i]; if Res.FFullEvaluated then begin Res.AddReference; exit; end; end; end; end; // check the maximum needed PParent := Parent.Parent; if (PParent is TFpPascalExpressionPartBracketIndex) and (PParent.Count = 2) then begin Itm := PParent.Items[1]; if (Itm is TFpPascalExpressionPartOperatorArraySlice) then begin if TFpPascalExpressionPartOperatorArraySlice(Itm).Count = 2 then Itm := TFpPascalExpressionPartOperatorArraySlice(Itm).Items[1] else Itm := nil; end; if (Itm <> nil) and (Itm.ResultValue <> nil) then if CustomMaxCnt then MaxCnt := Min(MaxCnt, Itm.ResultValue.AsInteger+101) // Cache 100 extra else MaxCnt := Itm.ResultValue.AsInteger+101; end; if (Result <> nil) and (Res.FList.Count >= MaxCnt) then begin// cached Res.AddReference; exit; end; Result := TFpValueFlatteArray.Create(0); Seen := TAddrSeenList.Create; Seen.Capacity := 256; TpSym := FirstVal.TypeInfo; try if (FirstVal.Kind = skArray) then begin FlattenArray(FirstVal, nil, 0, -1, '', Max(1, ExpandArrayDepth)); end else begin DA := FirstVal.DataAddress; Seen.Add(DA, 0); InternalAdd(FirstVal, 0, -1, ''); if not IsReadableLoc(DA) then exit; if IsError(ExpressionData.Error) then exit; Res.FFullEvaluated := FlattenRecurse(FirstVal, 0, ''); end; finally Seen.Free; end; if (not SkipCache) and (ExpressionData.GlobalCache <> nil) then begin if ListCache = nil then begin ListCache := TFpPascalExpressionCacheFlatten.Create; ExpressionData.GlobalCache[Pointer(TFpPascalExpressionPartIntrinsic)] := ListCache; end; ListCache.Replace(CacheKey, Res); end; end; function TFpPascalExpressionPartIntrinsic.DoFlattenPlaceholder( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var f: TFpPascalExpressionPartContainer; begin Result := nil; f := Parent; while (f <> nil) and not( (f is TFpPascalExpressionPartBracketArgumentList) and (f.Count > 1) and (f.Items[0] is TFpPascalExpressionPartIntrinsic) and (TFpPascalExpressionPartIntrinsic(f.Items[0]).FIntrinsic = ifFlatten) ) do f := f.Parent; if f = nil then begin SetError(':_ outside of :flatten'); exit; end; if not CheckArgumentCount(AParams, 0) then exit; Result := TFpPascalExpressionPartIntrinsic(f.Items[0]).FFlattenCurrentValOrig; if Result <> nil then Result.AddReference; end; function TFpPascalExpressionPartIntrinsic.DoRefCnt( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Tmp: TFpValue; rcnt: Int64; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Tmp, 'argument required') then exit; if not Tmp.GetFpcRefCount(rcnt) then begin SetError('argument not supported'); exit; end; Result := TFpValueConstNumber.Create(QWord(rcnt), True) end; function TFpPascalExpressionPartIntrinsic.DoPos( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Tmp, Tmp2, CmpCase: TFpValue; s1, s2: String; begin Result := nil; if not CheckArgumentCount(AParams, 2, 3) then exit; if not GetArg(AParams, 1, Tmp, 'argument required') then exit; if not GetArg(AParams, 2, Tmp2, 'argument required') then exit; CmpCase := nil; if AParams.Count = 4 then begin if not GetArg(AParams, 3, CmpCase, 'argument required') then exit; if (CmpCase.Kind <> skBoolean) then begin SetError('bool argument expected'); exit; end; end; s1 := Tmp.AsString; s2 := Tmp2.AsString; if (CmpCase <> nil) and (CmpCase.AsBool) then begin s1 := AnsiLowerCase(s1); s2 := AnsiLowerCase(s2); end; if (s1 = '') or (s2 = '') then Result := TFpValueConstNumber.Create(0, True) else Result := TFpValueConstNumber.Create(pos(s1, s2), True); end; function TFpPascalExpressionPartIntrinsic.DoSubStr( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Tmp, Tmp2, Tmp3, Tmp4: TFpValue; s1: String; w1: WideString; p1, p2: Int64; UsePtr: Boolean; Addr: QWord; t: TFpSymbol; Size: TFpDbgValueSize; ctx: TFpDbgLocationContext; begin Result := nil; if not CheckArgumentCount(AParams, 3,4) then exit; if not GetArg(AParams, 1, Tmp, 'argument required') then exit; if not GetArg(AParams, 2, Tmp2, 'argument required') then exit; if not GetArg(AParams, 3, Tmp3, 'argument required') then exit; UsePtr := False; if AParams.Count = 5 then begin if not GetArg(AParams, 4, Tmp4, 'argument required') then exit; if (Tmp4.Kind <> skBoolean) then begin SetError('bool argument expected'); exit; end; UsePtr := Tmp4.AsBool; end; if not (Tmp.Kind in [skString, skAnsiString, skWideString]) then UsePtr := True; if svfInteger in Tmp2.FieldFlags then p1 := Tmp2.AsInteger else if svfCardinal in Tmp2.FieldFlags then {$PUSH}{$R-}{$Q-} p1 := Int64(Tmp2.AsCardinal) {$POP} else begin SetError('int argument expected'); exit; end; if (p1 < 1) and (not UsePtr) then begin SetError('argument >= 1 expected'); exit; end; if svfInteger in Tmp3.FieldFlags then p2 := Tmp3.AsInteger else if svfCardinal in Tmp3.FieldFlags then {$PUSH}{$R-}{$Q-} p2 := Int64(Tmp3.AsCardinal) {$POP} else begin SetError('int argument expected'); exit; end; if (p2 < 1) and (not UsePtr) then begin SetError('argument >= 1 expected'); exit; end; if UsePtr then begin if not (Tmp.Kind in [skPointer, skString, skAnsiString, skWideString, skAddress]) then begin SetError('argument 1 not supported'); end; Addr := Tmp.AsCardinal; if Addr = 0 then begin Result := TFpValueConstString.Create(''); exit; end; if Tmp.Kind = skPointer then begin Size := SizeVal(1); t := Tmp.TypeInfo; if t <> nil then t := t.TypeInfo; if (t = nil) or // Only test for hardcoded size. TODO: dwarf 3 could have variable size, but for char that is not expected not t.ReadSize(nil, Size) then Size := SizeVal(1); end; ctx := ExpressionData.Scope.LocationContext; {$PUSH}{$R-}{$Q-} if (Tmp.Kind = skWideString) or ( (Tmp.Kind = skPointer) and (Size.Size = 2)) then begin if not ( (ctx.MemManager.SetLength(w1, p2)) and (ctx.ReadMemory(TargetLoc(Addr+QWord(p1*2)), SizeVal(p2*2), @w1[1])) ) then begin SetError(ctx.LastMemError); s1 := ''; end else s1 := w1; end else begin if not ( (ctx.MemManager.SetLength(s1, p2)) and (ctx.ReadMemory(TargetLoc(Addr+QWord(p1)), SizeVal(p2), @s1[1])) ) then begin SetError(ctx.LastMemError); s1 := ''; end; end; {$POP} Result := TFpValueConstString.Create(s1); end else begin if not Tmp.GetSubString(p1, p2, s1) and (s1 = '') then SetError(Tmp.LastError); Result := TFpValueConstString.Create(s1); end; end; function TFpPascalExpressionPartIntrinsic.DoLower( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; Result := TFpValueConstString.Create(AnsiLowerCase(Arg.AsString)); end; function TFpPascalExpressionPartIntrinsic.DoUpper( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; Result := TFpValueConstString.Create(AnsiUpperCase(Arg.AsString)); end; function TFpPascalExpressionPartIntrinsic.DoRound( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg, Digits: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1, 2) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; Digits := nil; if AParams.Count = 3 then begin if not GetArg(AParams, 2, Digits, 'optional') then exit; if not (Digits.Kind in [skCardinal, skInteger]) then begin SetError('int argument expected'); exit; end; end; if (Digits = nil) or (Digits.AsInteger = 0) then Result := TFpValueConstNumber.Create(QWord(Round(Arg.AsFloat)), True) else Result := TFpValueConstFloat.Create(RoundTo(Arg.AsFloat, Digits.AsInteger)); end; function TFpPascalExpressionPartIntrinsic.DoTrunc( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; Result := TFpValueConstNumber.Create(QWord(trunc(Arg.AsFloat)), True); end; function TFpPascalExpressionPartIntrinsic.DoSqrt( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sqrt(Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sqrt(Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sqrt(Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoPi(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; begin if not CheckArgumentCount(AParams, 0) then exit; Result := TFpValueConstFloat.Create(Pi) end; function TFpPascalExpressionPartIntrinsic.DoLn(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Ln(Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Ln(Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Ln(Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoLog(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; n: Extended; begin Result := nil; if not CheckArgumentCount(AParams, 2) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then n := Arg.AsFloat else if Arg.FieldFlags * [svfInteger, svfCardinal] <> [] then n := Arg.AsCardinal else SetError('Argument not numeric'); if not GetArg(AParams, 2, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(LogN(n,Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(LogN(n,Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(LogN(n,Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoSin(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sin(Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sin(Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Sin(Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoCos(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Cos(Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Cos(Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Cos(Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoTan(AParams: TFpPascalExpressionPartBracketArgumentList ): TFpValue; var Arg: TFpValue; begin Result := nil; if not CheckArgumentCount(AParams, 1) then exit; if not GetArg(AParams, 1, Arg, 'argument required') then exit; if svfFloat in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Tan(Arg.AsFloat)) else if svfInteger in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Tan(Arg.AsInteger)) else if svfCardinal in Arg.FieldFlags then Result := TFpValueConstFloat.Create(Tan(Arg.AsInteger)) else SetError('Argument not numeric'); end; function TFpPascalExpressionPartIntrinsic.DoGetResultValue: TFpValue; var p: TFpPascalExpressionPartBracketArgumentList; begin Result := nil; if not (FIntrinsic in [ifFlattenPlaceholder, ifPi]) then begin // this gets called, if an intrinsic has no () after it. I.e. no arguments and no empty brackets SetError('wrong argument count'); exit; end; p := TFpPascalExpressionPartBracketArgumentList.Create(ExpressionData, nil); p.FList.Add(Self); Result := DoGetResultValue(p); p.FList.Clear; // make sure the container does not destroy self p.Free; end; function TFpPascalExpressionPartIntrinsic.DoGetResultValue( AParams: TFpPascalExpressionPartBracketArgumentList): TFpValue; begin Result := nil; case FIntrinsic of ifTry: Result := DoTry(AParams); ifTryN: Result := DoTryN(AParams); ifObj: Result := DoObj(AParams); ifOrd: Result := DoOrd(AParams); ifLength: Result := DoLength(AParams); ifChildClass: Result := DoChildClass(AParams); ifRefCount: Result := DoRefCnt(AParams); ifPos: Result := DoPos(AParams); ifFlatten: Result := DoFlatten(AParams); ifFlattenPlaceholder: Result := DoFlattenPlaceholder(AParams); ifSubStr: Result := DoSubStr(AParams); ifLower: Result := DoLower(AParams); ifUpper: Result := DoUpper(AParams); ifRound: Result := DoRound(AParams); ifTrunc: Result := DoTrunc(AParams); ifSqrt: Result := DoSqrt(AParams); ifPi: Result := DoPi(AParams); ifLn: Result := DoLn(AParams); ifLog: Result := DoLog(AParams); ifSin: Result := DoSin(AParams); ifCos: Result := DoCos(AParams); ifTan: Result := DoTan(AParams); end; {$IFDEF WITH_REFCOUNT_DEBUG} if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue') {$ENDIF} end; procedure TFpPascalExpressionPartIntrinsic.Assign(ASourcePart: TFpPascalExpressionPart); begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartIntrinsic then FIntrinsic := TFpPascalExpressionPartIntrinsic(ASourcePart).FIntrinsic; end; constructor TFpPascalExpressionPartIntrinsic.Create( AnExpressionData: TFpPascalExpressionSharedData; AStartChar: PChar; AnEndChar: PChar; AnIntrinsic: TFpIntrinsicFunc); begin inherited Create(AnExpressionData, AStartChar, AnEndChar); FIntrinsic := AnIntrinsic; end; destructor TFpPascalExpressionPartIntrinsic.Destroy; begin inherited Destroy; FChildClassCastType.ReleaseReference; end; function TFpPascalExpressionPartIntrinsic.ReturnsVariant: boolean; begin Result := (inherited ReturnsVariant) or (FIntrinsic in [ifChildClass, ifTry, ifTryN]); // TODO: compare types of each argument for ifTry/N end; function TFpPascalExpressionPartIntrinsic.AcceptParamAsSeparator( AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer; var AResult: TFpPascalExpressionPart): boolean; var LastItm: TFpPascalExpressionPart; begin Result := False; LastItm := ABracketsPart.LastItem; if ( ((FIntrinsic = ifFlatten) and (ABracketsPart.Count >= 3)) or // only for keys / not for the initial value ((FIntrinsic = ifObj) and (ABracketsPart.Count >= 2)) ) and (AParamPart is TFpPascalExpressionPartOperatorColon) and (TFpPascalExpressionPartOperatorColon(AParamPart).Count = 0) and not(LastItm is TFpPascalExpressionPartOperatorColonAsSeparator) then begin // Handle ":" as separator AResult := TFpPascalExpressionPartOperatorColonAsSeparator.Create(ExpressionData, AParamPart.FStartChar, AParamPart.FEndChar); AParamPart.Free; LastItm.HandleNextPart(AResult); Result := True; end; end; procedure TFpPascalExpressionPartIntrinsic.HandleNewParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); begin if (FIntrinsic = ifFlatten) and (ABracketsPart.Count > 2) then begin // part 1 is the intrinsic / part 2 is the initial object // Part 3..n are the member expressions if AParamPart is TFpPascalExpressionPartIdentifier then begin TFpPascalExpressionPartIdentifier(AParamPart).OnGetSymbol := @DoGetMemberForFlattenExpr; end; end; end; procedure TFpPascalExpressionPartIntrinsic.HandleEndOfParameterInList( AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); var n: TFpPascalExpressionPart; begin inherited HandleEndOfParameterInList(AParamPart, ABracketsPart); if FIntrinsic = ifObj then begin if (ABracketsPart.Count > 1) and (not (ABracketsPart.LastItem is TFpPascalExpressionPartOperatorColonAsSeparator)) then begin SetError('Argument must be "key:name"'); exit; end; n := TFpPascalExpressionPartOperatorColonAsSeparator(ABracketsPart.LastItem).Items[0]; if (not (n is TFpPascalExpressionPartIdentifier)) then SetError('Argument must be "key" must be identifier'); end; end; { TFpPascalExpressionPartConstantNumber } function TFpPascalExpressionPartConstantNumber.DoGetResultValue: TFpValue; var i: QWord; e: word; ds, ts: Char; begin ds := DecimalSeparator; ts := ThousandSeparator; DecimalSeparator := '.'; ThousandSeparator := #0; Val(GetText, i, e); DecimalSeparator := ds; ThousandSeparator := ts; if e <> 0 then begin Result := nil; SetErrorWithPos(fpErrPasParserExpectedNumber_p, [GetText(MAX_ERR_EXPR_QUOTE_LEN)]); exit; end; if FStartChar^ in ['0'..'9'] then Result := TFpValueConstNumber.Create(i, False) else Result := TFpValueConstNumber.Create(i, True); // hex,oct,bin values default to signed {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end; { TFpPascalExpressionPartConstantNumberFloat } function TFpPascalExpressionPartConstantNumberFloat.DoGetResultValue: TFpValue; var f: Extended; s: String; ds, ts: Char; ok: Boolean; begin s := GetText; ds := DecimalSeparator; ts := ThousandSeparator; DecimalSeparator := '.'; ThousandSeparator := #0; ok := TextToFloat(PChar(s), f); DecimalSeparator := ds; ThousandSeparator := ts; if not ok then begin Result := nil; SetErrorWithPos(fpErrPasParserExpectedNumber_p, [GetText(MAX_ERR_EXPR_QUOTE_LEN)]); exit; end; Result := TFpValueConstFloat.Create(f); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end; { TFpPascalExpressionPartConstantText } function TFpPascalExpressionPartConstantText.DoGetResultValue: TFpValue; begin if Length(FValue) = 1 then Result := TFpValueConstChar.Create(FValue[1]) else Result := TFpValueConstString.Create(FValue); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end; procedure TFpPascalExpressionPartConstantText.Assign(ASourcePart: TFpPascalExpressionPart); begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartConstantText then FValue := TFpPascalExpressionPartConstantText(ASourcePart).FValue; end; function CheckToken(const tk: String; CurPtr: PChar): boolean; inline; var p, t: PChar; l: Integer; begin Result := False; l := Length(tk); p := CurPtr + l; t := @tk[l]; while p > CurPtr do begin if chr(ord(p^) and $DF) <> t^ then exit; dec(p); dec(t); end; Result := True; end; { TFpPascalExpressionSharedData } function TFpPascalExpressionSharedData.GetValid: Boolean; begin Result := not IsError(FError); end; function TFpPascalExpressionSharedData.GetTextExpressionAddr: PChar; begin Result := PChar(FTextExpression); end; procedure TFpPascalExpressionSharedData.SetError(AMsg: String); begin if IsError(FError) then begin DebugLn(DBG_WARNINGS, ['Skipping error ', AMsg]); exit; end; SetError(fpErrAnyError, [AMsg]); DebugLn(DBG_WARNINGS, ['PARSER ERROR ', AMsg]); end; procedure TFpPascalExpressionSharedData.SetError(AnErrorCode: TFpErrorCode; const AnNestedErr: TFpError); begin SetError(AnErrorCode, [], AnNestedErr); end; procedure TFpPascalExpressionSharedData.SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError); begin FError := ErrorHandler.CreateError(AnErrorCode, AnNestedErr, AData); DebugLn(DBG_WARNINGS, ['Setting error ', ErrorHandler.ErrorAsString(FError)]); end; procedure TFpPascalExpressionSharedData.SetError(const AnErr: TFpError); begin FError := AnErr; DebugLn(DBG_WARNINGS, ['Setting error ', ErrorHandler.ErrorAsString(FError)]); end; procedure TFpPascalExpressionSharedData.ClearError; begin FError := NoError; end; function TFpPascalExpressionSharedData.PosFromPChar(APChar: PChar): Integer; begin Result := APChar - @FTextExpression[1] + 1; end; constructor TFpPascalExpressionSharedData.Create(ATextExpression: String; AScope: TFpDbgSymbolScope ); begin inherited Create; AddReference; DisableFloatExceptions; FTextExpression := ATextExpression; FScope := AScope; FScope.AddReference; FError := NoError; end; destructor TFpPascalExpressionSharedData.Destroy; begin EnableFloatExceptions; inherited Destroy; FScope.ReleaseReference; end; function TFpPascalExpressionSharedData.GetDbgSymbolForIdentifier(AnIdent: String; AFindFlags: TFindExportedSymbolsFlags): TFpValue; begin if FScope <> nil then Result := FScope.FindSymbol(AnIdent, '', AFindFlags) else Result := nil; end; function TFpPascalExpressionSharedData.GetRegisterValue(AnIdent: String): TFpValue; var RNum: Cardinal; RSize: Integer; RVal: QWord; Reg: TDbgRegisterValue; begin Result := nil; if FScope = nil then exit; if not FScope.MemManager.RegisterNumber(AnIdent, RNum) then exit; RSize := FScope.MemManager.RegisterSize(RNum); if (RSize <= 8) and FScope.LocationContext.ReadUnsignedInt(RegisterLoc(RNum), SizeVal(RSize), RVal) then begin Result := TFpValueConstNumber.Create(RVal, False); end else begin Reg := FScope.LocationContext.GetRegister(RNum); if Reg <> nil then Result := TFpValueConstString.Create(Reg.StrValue); end; end; { TFpPascalExpression } procedure TFpPascalExpression.Parse; var CurPtr, EndPtr, TokenEndPtr: PChar; CurPart, PrevPart, NewPart: TFpPascalExpressionPart; // "Foo-Error 'token' at pos N after 'prev token'" procedure SetParserError(AnErrorCode: TFpErrorCode); begin if PrevPart = nil then SetError(AnErrorCode, [GetFirstToken(CurPtr)], CreateError(fpErrPasParser_AtStart, []) ) else SetError(AnErrorCode, [GetFirstToken(CurPtr)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr), PrevPart.GetText(MAX_ERR_EXPR_QUOTE_LEN)]) ); end; procedure SetParserError(AnErrorCode: TFpErrorCode; AData: array of const); begin if PrevPart = nil then SetError(AnErrorCode, AData, CreateError(fpErrPasParser_AtStart, []) ) else SetError(AnErrorCode, AData, CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr), PrevPart.GetText(MAX_ERR_EXPR_QUOTE_LEN)]) ); end; procedure SetParserErrorPosOnly(AnErrorCode: TFpErrorCode); begin if PrevPart = nil then SetError(AnErrorCode, [], CreateError(fpErrPasParser_AtStart, []) ) else SetError(AnErrorCode, [], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr), PrevPart.GetText(MAX_ERR_EXPR_QUOTE_LEN)]) ); end; procedure AddPart(AClass: TFpPascalExpressionPartClass); begin NewPart := AClass.Create(FSharedData, CurPtr, TokenEndPtr-1); end; procedure AddPlusMinus; begin if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext) then AddPart(TFpPascalExpressionPartOperatorUnaryPlusMinus) else AddPart(TFpPascalExpressionPartOperatorPlusMinus); end; procedure AddIntrinsic; var intr: TFpPascalExpressionPart; begin while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_', '0'..'9', '$'] do inc(TokenEndPtr); intr := LookupIntrinsic(CurPtr, TokenEndPtr - CurPtr); if intr = nil then SetParserError(fpErrPasParserUnknownIntrinsic_p) else NewPart := intr; end; function CheckOpenBracket: Boolean; var p: PChar; begin p := TokenEndPtr; while p^ in [' ', #9, #10, #13] do inc(p); Result := p^ = '('; end; procedure AddIdentifier; begin while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_', '0'..'9', '$'] do inc(TokenEndPtr); // TODO: Check functions not, and, in, as, is ... if (CurPart <> nil) and (CurPart.CanHaveOperatorAsNext) then case TokenEndPtr - CurPtr of 3: case chr(ord(CurPtr^) AND $DF) of 'D': if CheckToken('IV', CurPtr) then NewPart := TFpPascalExpressionPartOperatorMulDiv.Create(FSharedData, CurPtr, TokenEndPtr-1); 'M': if CheckToken('OD', CurPtr) then NewPart := TFpPascalExpressionPartOperatorMulDiv.Create(FSharedData, CurPtr, TokenEndPtr-1); 'A': if CheckToken('ND', CurPtr) then NewPart := TFpPascalExpressionPartOperatorAnd.Create(FSharedData, CurPtr, TokenEndPtr-1); 'X': if CheckToken('OR', CurPtr) then NewPart := TFpPascalExpressionPartOperatorOr.Create(FSharedData, ootXor, CurPtr, TokenEndPtr-1); 'N': if CheckToken('OT', CurPtr) then NewPart := TFpPascalExpressionPartOperatorUnaryNot.Create(FSharedData, CurPtr, TokenEndPtr-1); 'S': if CheckToken('HL', CurPtr) then NewPart := TFpPascalExpressionPartOperatorShl.Create(FSharedData, CurPtr, TokenEndPtr-1) else if CheckToken('HR', CurPtr) then NewPart := TFpPascalExpressionPartOperatorShr.Create(FSharedData, CurPtr, TokenEndPtr-1); end; 2: case chr(ord(CurPtr^) AND $DF) of 'I': if CheckToken('N', CurPtr) then NewPart := TFpPascalExpressionPartOperatorMemberIn.Create(FSharedData, CurPtr, TokenEndPtr-1); 'O': if CheckToken('R', CurPtr) then NewPart := TFpPascalExpressionPartOperatorOr.Create(FSharedData, ootOr, CurPtr, TokenEndPtr-1); end; end else case TokenEndPtr - CurPtr of 3: case chr(ord(CurPtr^) AND $DF) of 'N': if CheckToken('OT', CurPtr) then NewPart := TFpPascalExpressionPartOperatorUnaryNot.Create(FSharedData, CurPtr, TokenEndPtr-1); end; end; if (FIntrinsicPrefix = ipNoPrefix) and CheckOpenBracket then begin NewPart := LookupIntrinsic(CurPtr, TokenEndPtr - CurPtr); if (NewPart <> nil) then exit; end; if NewPart = nil then NewPart := TFpPascalExpressionPartIdentifier.Create(FSharedData, CurPtr, TokenEndPtr-1); end; procedure HandleExclamation; begin if (CurPart = nil) or (not CurPart.CanHaveOperatorAsNext) then begin SetParserError(fpErrPasParserUnexpectedToken_p); exit; end; if not Valid then exit; if FPreviousArraySlice <> nil then begin CurPart := FPreviousArraySlice.AddController(CurPart); FPreviousArraySlice := FPreviousArraySlice.FPreviousArraySlice; end; end; procedure HandleDot; begin while TokenEndPtr^ = '.' do inc(TokenEndPtr); case TokenEndPtr - CurPtr of 1: AddPart(TFpPascalExpressionPartOperatorMemberOf); 2: if CurPart.SurroundingBracket is TFpPascalExpressionPartBracketIndex then AddPart(TFpPascalExpressionPartOperatorArraySlice) else SetParserError(fpErrPasParserUnexpectedToken_p); otherwise SetParserError(fpErrPasParserUnexpectedToken_p); 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 if (CurPart=nil) then begin SetParserError(fpErrPasParserUnexpectedToken_p); exit; end; BracketPart := CurPart.SurroundingBracket; if BracketPart = nil then begin SetParserError(fpErrPasParserMissingOpenBracket_p); end else if not (BracketPart is ABracketClass) then begin SetParserError(fpErrPasParserWrongOpenBracket_p, [GetFirstToken(CurPtr), FSharedData.PosFromPChar(BracketPart.StartChar), BracketPart.GetText(MAX_ERR_EXPR_QUOTE_LEN)]); end else begin TFpPascalExpressionPartBracket(BracketPart).CloseBracket(CurPart, @FPreviousArraySlice, CurPtr, TokenEndPtr-1); CurPart := BracketPart; end; end; procedure AddRegister; begin while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do inc(TokenEndPtr); AddPart(TFpPascalExpressionPartCpuRegister); end; procedure AddConstNumber; begin case CurPtr^ of '$': while TokenEndPtr^ in ['a'..'f', 'A'..'F', '0'..'9'] do inc(TokenEndPtr); '&': if TokenEndPtr^ in ['a'..'z', 'A'..'Z'] then begin // escaped keyword used as identifier while TokenEndPtr^ in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do inc(TokenEndPtr); inc(CurPtr); NewPart := TFpPascalExpressionPartIdentifier.Create(FSharedData, CurPtr, TokenEndPtr-1); exit; end else while TokenEndPtr^ in ['0'..'7'] do inc(TokenEndPtr); '%': if TokenEndPtr^ in ['a'..'z', 'A'..'Z'] then begin inc(CurPtr); AddRegister; exit; end else while TokenEndPtr^ in ['0'..'1'] do inc(TokenEndPtr); '0'..'9': if (CurPtr^ = '0') and ((CurPtr + 1)^ in ['x', 'X']) and ((CurPtr + 2)^ in ['a'..'f', 'A'..'F', '0'..'9']) then begin inc(TokenEndPtr, 2); while TokenEndPtr^ in ['a'..'f', 'A'..'F', '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^ = '.') and (TokenEndPtr[1] <> '.') then begin inc(TokenEndPtr); while TokenEndPtr^ in ['0'..'9'] do inc(TokenEndPtr); if TokenEndPtr^ in ['a'..'z', 'A'..'Z', '_'] then SetParserError(fpErrPasParserUnexpectedToken_p) else AddPart(TFpPascalExpressionPartConstantNumberFloat); exit; end; end; end; if (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'9', 'a'..'z', 'A'..'Z']) or (TokenEndPtr[-1] in ['x', '$', '&', '%']) then begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end else AddPart(TFpPascalExpressionPartConstantNumber); end; procedure HandleCompare; begin if (CurPtr^ = '<') then begin if (TokenEndPtr^ = '<') then begin inc(TokenEndPtr); AddPart(TFpPascalExpressionPartOperatorShl); exit; end; if (TokenEndPtr^ in ['>', '=']) then inc(TokenEndPtr); end else if (CurPtr^ = '>') then begin if (TokenEndPtr^ = '>') then begin inc(TokenEndPtr); AddPart(TFpPascalExpressionPartOperatorShr); exit; end; if (TokenEndPtr^ in ['<', '=']) then inc(TokenEndPtr); end; AddPart(TFpPascalExpressionPartOperatorCompare); end; procedure HandleComma; begin if (CurPart=nil) or (not CurPart.HandleSeparator(ppstComma, CurPart)) then SetParserError(fpErrPasParserUnexpectedToken_p); end; procedure AddConstChar; var str: string; p: PChar; c: LongInt; WasQuote: Boolean; begin dec(TokenEndPtr); str := ''; WasQuote := False; while (TokenEndPtr < EndPtr) and Valid do begin case TokenEndPtr^ of '''': begin if WasQuote then str := str + ''''; WasQuote := False; inc(TokenEndPtr); p := TokenEndPtr; while (TokenEndPtr < EndPtr) and (TokenEndPtr^ <> '''') do inc(TokenEndPtr); str := str + copy(p, 1, TokenEndPtr - p); if (TokenEndPtr < EndPtr) and (TokenEndPtr^ = '''') then begin inc(TokenEndPtr); end else begin SetParserErrorPosOnly(fpErrPasParserUnterminatedString_p); exit; end; end; '#': begin WasQuote := False; inc(TokenEndPtr); if not (TokenEndPtr < EndPtr) then begin SetError(fpErrPasParserUnexpectedEndOfExpression, [GetFirstToken(CurPtr)]); exit; end; p := TokenEndPtr; case TokenEndPtr^ of '$': begin inc(TokenEndPtr); if (not (TokenEndPtr < EndPtr)) or (not (TokenEndPtr^ in ['0'..'9', 'a'..'f', 'A'..'F'])) then begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end; while (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'9', 'a'..'f', 'A'..'F']) do inc(TokenEndPtr); end; '&': begin inc(TokenEndPtr); if (not (TokenEndPtr < EndPtr)) or (not (TokenEndPtr^ in ['0'..'7'])) then begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end; while (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'7']) do inc(TokenEndPtr); end; '%': begin inc(TokenEndPtr); if (not (TokenEndPtr < EndPtr)) or (not (TokenEndPtr^ in ['0'..'1'])) then begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end; while (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'1']) do inc(TokenEndPtr); end; '0'..'9': begin while (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'9']) do inc(TokenEndPtr); end; else begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end; end; c := StrToIntDef(copy(p , 1 , TokenEndPtr - p), -1); if (c < 0) or ( (TokenEndPtr < EndPtr) and (TokenEndPtr^ in ['0'..'9', 'a'..'z', 'A'..'Z']) ) then begin SetError(fpErrPasParserExpectedNumber_p, [GetFirstToken(CurPtr+1)], CreateError(fpErrPasParser_PositionAfter, [FSharedData.PosFromPChar(CurPtr+1), '#']) ); exit; end; if c > 255 then // todo: need wide handling str := str + WideChar(c) else str := str + Char(c); end; ' ', #9, #10, #13: inc(TokenEndPtr); else break; end; end; if not Valid then exit; AddPart(TFpPascalExpressionPartConstantText); TFpPascalExpressionPartConstantText(NewPart).FValue := str; end; begin if FSharedData.TextExpression = '' then begin SetError(fpErrPasParserEmptyExpression); exit; end; CurPtr := FSharedData.TextExpressionAddr; EndPtr := CurPtr + length(FSharedData.TextExpression); while (CurPtr^ in [' ', #9, #10, #13]) and (CurPtr < EndPtr) do Inc(CurPtr); if CurPtr = EndPtr then begin SetError(fpErrPasParserEmptyExpression); exit; end; CurPart := nil; PrevPart := nil; While (CurPtr < EndPtr) and Valid 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; if (FIntrinsicPrefix = ipExclamation) and (CurPtr^ = '!') and ((CurPart = nil) or (not CurPart.CanHaveOperatorAsNext) ) then begin inc(CurPtr); AddIntrinsic; end else if (CurPtr^ = ':') then begin if (CurPart <> nil) and CurPart.CanHaveOperatorAsNext then begin AddPart(TFpPascalExpressionPartOperatorColon); end else if (FIntrinsicPrefix = ipColon) then begin inc(CurPtr); AddIntrinsic; end else begin SetParserError(fpErrPasParserUnexpectedToken_p); break; end; end else case CurPtr^ of '@' : AddPart(TFpPascalExpressionPartOperatorAddressOf); '?' : AddPart(TFpPascalExpressionPartOperatorQuestionMark); '!' : HandleExclamation; '^': 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 SetParserError(fpErrPasParserUnexpectedToken_p); break; end; end; if not Valid then break; PrevPart := NewPart; 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(fpErrPasParserEmptyExpression); end else if CurPart <> nil then CurPart := CurPart.TopParent; if FPreviousArraySlice <> nil then CurPart := FPreviousArraySlice.AddControllerRecursive(CurPart); FExpressionPart := CurPart; end; function TFpPascalExpression.GetResultValue: TFpValue; begin if (FExpressionPart = nil) or (not Valid) then Result := nil else begin Result := FExpressionPart.ResultValue; if (Result = nil) and Valid then SetError(fpErrAnyError, ['Internal eval error']); end; end; function TFpPascalExpression.GetGlobalCache: TFpDbgDataCache; begin Result := FSharedData.GlobalCache; end; function TFpPascalExpression.GetOnFunctionCall: TFpPascalParserCallFunctionProc; begin Result := FSharedData.OnFunctionCall; end; function TFpPascalExpression.GetAutoDeref: Boolean; begin Result := FSharedData.AutoDeref; end; function TFpPascalExpression.GetError: TFpError; begin Result := FSharedData.Error; end; function TFpPascalExpression.GetFixPCharIndexAccess: Boolean; begin Result := FSharedData.FixPCharIndexAccess; end; function TFpPascalExpression.GetHasPCharIndexAccess: Boolean; begin Result := FSharedData.HasPCharIndexAccess; end; function TFpPascalExpression.GetValid: Boolean; begin Result := FSharedData.Valid; end; procedure TFpPascalExpression.SetAutoDeref(AValue: Boolean); begin FSharedData.AutoDeref := AValue; end; procedure TFpPascalExpression.SetGlobalCache(AValue: TFpDbgDataCache); begin FSharedData.GlobalCache := AValue; end; procedure TFpPascalExpression.SetOnFunctionCall(AValue: TFpPascalParserCallFunctionProc); begin FSharedData.OnFunctionCall := AValue; end; procedure TFpPascalExpression.SetFixPCharIndexAccess(AValue: Boolean); begin FSharedData.FixPCharIndexAccess := AValue; end; function TFpPascalExpression.LookupIntrinsic(AStart: PChar; ALen: Integer ): TFpPascalExpressionPart; var Intr: TFpIntrinsicFunc; begin Result := nil; Intr := ifErrorNotFound; case ALen of 1: begin if AStart^ = '_' then Intr := ifFlattenPlaceholder; end; 2: begin if strlicomp(AStart, 'CC', 2) = 0 then Intr := ifChildClass else if strlicomp(AStart, 'F_', 2) = 0 then Intr := ifFlatten else if strlicomp(AStart, 'PI', 2) = 0 then Intr := ifPi else if strlicomp(AStart, 'LN', 2) = 0 then Intr := ifLn ; end; 3: case AStart^ of 'l', 'L': if strlicomp(AStart, 'LEN', 3) = 0 then Intr := ifLength else if strlicomp(AStart, 'LOG', 3) = 0 then Intr := ifLog; 'p', 'P': if strlicomp(AStart, 'POS', 3) = 0 then Intr := ifPos; 'o', 'O': if strlicomp(AStart, 'ORD', 3) = 0 then Intr := ifOrd else if strlicomp(AStart, 'OBJ', 3) = 0 then Intr := ifObj; 't', 'T': if strlicomp(AStart, 'TRY', 3) = 0 then Intr := ifTry else if strlicomp(AStart, 'TAN', 3) = 0 then Intr := ifTan; 's', 'S': if strlicomp(AStart, 'SIN', 3) = 0 then Intr := ifSin; 'c', 'C': if strlicomp(AStart, 'COS', 3) = 0 then Intr := ifCos; end; 4: case AStart^ of 's', 'S': if strlicomp(AStart, 'SQRT', 4) = 0 then Intr := ifSqrt; 'l', 'L': if strlicomp(AStart, 'LOGN', 4) = 0 then Intr := ifLog; 't', 'T': if strlicomp(AStart, 'TRYN', 4) = 0 then Intr := ifTryN; end; 5: case AStart^ of 'l', 'L': if strlicomp(AStart, 'LOWER', 5) = 0 then Intr := ifLower; 'u', 'U': if strlicomp(AStart, 'UPPER', 5) = 0 then Intr := ifUpper; 'r', 'R': if strlicomp(AStart, 'ROUND', 5) = 0 then Intr := ifRound; 't', 'T': if strlicomp(AStart, 'TRUNC', 5) = 0 then Intr := ifTrunc else if strlicomp(AStart, 'TRYNN', 5) = 0 then Intr := ifTryN; end; 6: case AStart^ of 'l', 'L': if strlicomp(AStart, 'LENGTH', 6) = 0 then Intr := ifLength; 'r', 'R': if strlicomp(AStart, 'REFCNT', 6) = 0 then Intr := ifRefCount; 's', 'S': if strlicomp(AStart, 'SUBSTR', 6) = 0 then Intr := ifSubStr; end; 7: case AStart^ of 'f', 'F': if strlicomp(AStart, 'FLATTEN', 7) = 0 then Intr := ifFlatten; end; end; if Intr <> ifErrorNotFound then begin Result := TFpPascalExpressionPartIntrinsic.Create(FSharedData, AStart, AStart+ALen, Intr); exit; end; if (FOnFindIntrinsc <> nil) and (ALen > 0) then begin Result := FOnFindIntrinsc(Self, AStart, ALen); end; end; procedure TFpPascalExpression.SetError(AnErrorCode: TFpErrorCode; const AnNestedErr: TFpError); begin FSharedData.SetError(AnErrorCode, AnNestedErr); end; procedure TFpPascalExpression.SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError); begin FSharedData.SetError(AnErrorCode, AData, AnNestedErr); end; constructor TFpPascalExpression.Create(ATextExpression: String; AScope: TFpDbgSymbolScope; ASkipParse: Boolean); begin FSharedData := TFpPascalExpressionSharedData.Create(ATextExpression, AScope); if not ASkipParse then Parse; end; destructor TFpPascalExpression.Destroy; begin FreeAndNil(FExpressionPart); inherited Destroy; FSharedData.ReleaseReference; end; function TFpPascalExpression.DebugDump(AWithResults: Boolean): String; begin Result := 'TFpPascalExpression: ' + FSharedData.TextExpression + LineEnding + 'Valid: ' + dbgs(Valid) + ' Error: "' + dbgs(ErrorCode(Error)) + '"'+ 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.ResetEvaluationRecursive; 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: TFpValue; 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; function TFpPascalExpressionPart.GetPos: Integer; begin Result := ExpressionData.PosFromPChar(FStartChar); end; function TFpPascalExpressionPart.GetFullText(AMaxLen: Integer): String; begin Result := GetText(AMaxLen); end; function TFpPascalExpressionPart.ReturnsVariant: boolean; begin Result := False; if FResultValue <> nil then Result := (FResultValue.Flags * [vfVariant, vfArrayOfVariant] <> []); end; function TFpPascalExpressionPart.IsClosed: boolean; begin Result := True; end; function TFpPascalExpressionPart.FindInParents(APart: TFpPascalExpressionPart): Boolean; var p: TFpPascalExpressionPart; begin p := Self; while p <> nil do begin Result := APart = p; if Result then exit; p := p.Parent; end; Result := False; end; procedure TFpPascalExpressionPart.SetError(AMsg: String); begin if AMsg = '' then AMsg := 'Invalid Expression'; ExpressionData.SetError(Format('%0:s at %1:d: "%2:s"', [AMsg, ExpressionData.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; function TFpPascalExpressionPart.CreateErrorWithPos(AnErrorCode: TFpErrorCode; AData: array of const; APos: integer): TFpError; begin if APos < 0 then APos := GetPos; if APos = 1 then Result := CreateError(AnErrorCode, AData, CreateError(fpErrPasParser_AtStart, [] )) else Result := CreateError(AnErrorCode, AData, CreateError(fpErrPasParser_Position, [GetPos])); end; procedure TFpPascalExpressionPart.SetErrorWithPos(AnErrorCode: TFpErrorCode; AData: array of const); begin ExpressionData.SetError(CreateErrorWithPos(AnErrorCode, AData)); end; procedure TFpPascalExpressionPart.SetError(AnErrorCode: TFpErrorCode; AData: array of const; const AnNestedErr: TFpError); begin ExpressionData.SetError(AnErrorCode, AData, AnNestedErr); end; procedure TFpPascalExpressionPart.SetError(AnError: TFpError); begin ExpressionData.SetError(AnError); end; procedure TFpPascalExpressionPart.Init; begin // end; procedure TFpPascalExpressionPart.Assign(ASourcePart: TFpPascalExpressionPart); begin FStartChar := ASourcePart.FStartChar; FEndChar := ASourcePart.FEndChar; FExpressionData := ASourcePart.ExpressionData; FPrecedence := ASourcePart.FPrecedence; end; function TFpPascalExpressionPart.FindCopiedInParents(ASourcePart, AFindInSourcePart: TFpPascalExpressionPart; AFindFlags: TFindInParentsFlags ): TFpPascalExpressionPart; begin Result := Self; while (Result <> nil) and (ASourcePart <> nil) do begin if AFindInSourcePart = ASourcePart then exit; if (fipIncludeBracketFunction in AFindFlags) and (ASourcePart is TFpPascalExpressionPartBracketArgumentList) and (TFpPascalExpressionPartContainer(ASourcePart).Count > 1) and (AFindInSourcePart = TFpPascalExpressionPartContainer(ASourcePart).Items[0]) then exit(TFpPascalExpressionPartContainer(ASourcePart).Items[0]); ASourcePart := ASourcePart.Parent; Result := Result.Parent; end; end; function TFpPascalExpressionPart.DoGetIsTypeCast: Boolean; begin Result := False; end; function TFpPascalExpressionPart.DoGetResultValue: TFpValue; begin Result := nil; SetError('Can not evaluate: "'+GetText+'"'); end; procedure TFpPascalExpressionPart.ResetEvaluation; begin FResultValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FResultValue, 'DoGetResultValue'){$ENDIF}; FResultValue := nil; FResultValDone := False; end; procedure TFpPascalExpressionPart.ResetEvaluationRecursive; begin ResetEvaluation; end; procedure TFpPascalExpressionPart.ResetEvaluationForAnchestors; begin ResetEvaluation; if Parent <> nil then Parent.ResetEvaluationForAnchestors; 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; procedure TFpPascalExpressionPart.DoParentIndexBraceClosed( APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); 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; var APart: TFpPascalExpressionPart): Boolean; begin Result := (Parent <> nil) and Parent.HandleSeparator(ASeparatorType, APart); end; procedure TFpPascalExpressionPart.GetFirstLastChar(out AFirst, ALast: PChar); begin AFirst := FStartChar; ALast := FEndChar; end; function TFpPascalExpressionPart.DebugText(AIndent: String; AWithResults: Boolean): String; begin Result := Format('%s%s at %d: "%s"', [AIndent, ClassName, ExpressionData.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(AnExpressionData: TFpPascalExpressionSharedData; AStartChar: PChar; AnEndChar: PChar); begin FExpressionData := AnExpressionData; FExpressionData.AddReference; FStartChar := AStartChar; FEndChar := AnEndChar; //FResultTypeFlag := rtUnknown; FResultValDone := False; Init; end; destructor TFpPascalExpressionPart.Destroy; begin inherited Destroy; FExpressionData.ReleaseReference; //FResultType.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultType'){$ENDIF}; FResultValue.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(@FResultValue, 'DoGetResultValue'){$ENDIF}; end; function TFpPascalExpressionPart.CreateCopy(ACopiedParent: TFpPascalExpressionPartContainer ): TFpPascalExpressionPart; begin Result := TFpPascalExpressionPartClass(ClassType).Create(ExpressionData, FStartChar, FEndChar); Result.FParent := ACopiedParent; Result.FIsCopy := True; //Result.ExpressionData.AddReference; Result.Assign(Self); end; procedure TFpPascalExpressionPart.BeginNeedCopy; begin // end; procedure TFpPascalExpressionPart.EndNeedCopy; begin // 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; function TFpPascalExpressionPart.AcceptParamAsSeparator(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer; var AResult: TFpPascalExpressionPart): boolean; begin Result := False; end; procedure TFpPascalExpressionPart.HandleNewParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); begin // end; procedure TFpPascalExpressionPart.HandleEndOfParameterInList(AParamPart: TFpPascalExpressionPart; ABracketsPart: TFpPascalExpressionPartContainer); begin // 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; procedure TFpPascalExpressionPartContainer.Assign(ASourcePart: TFpPascalExpressionPart); var AContainerSourcePart: TFpPascalExpressionPartContainer absolute ASourcePart; i: Integer; begin inherited Assign(ASourcePart); Clear; if ASourcePart is TFpPascalExpressionPartContainer then begin for i := 0 to AContainerSourcePart.Count - 1 do Add(AContainerSourcePart.Items[i].CreateCopy(Self)); end; end; procedure TFpPascalExpressionPartContainer.ResetEvaluationRecursive; var i: Integer; begin inherited ResetEvaluationRecursive; for i := 0 to Count - 1 do Items[i].ResetEvaluationRecursive; end; procedure TFpPascalExpressionPartContainer.GetFirstLastChar(out AFirst, ALast: PChar); var i: Integer; f, l: PChar; begin inherited GetFirstLastChar(AFirst, ALast); for i := 0 to Count -1 do begin Items[i].GetFirstLastChar(f,l); if (AFirst = nil) or ( (f <> nil) and (f < AFirst) ) then AFirst := f; if (ALast = nil) or ( (l <> nil) and (l > ALast) ) then ALast := l; end; 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; procedure TFpPascalExpressionPartContainer.BeginNeedCopy; var i: Integer; begin inherited BeginNeedCopy; for i := 0 to Count - 1 do Items[i].BeginNeedCopy; end; procedure TFpPascalExpressionPartContainer.EndNeedCopy; var i: Integer; begin inherited EndNeedCopy; for i := 0 to Count - 1 do Items[i].EndNeedCopy; end; function TFpPascalExpressionPartContainer.GetFullText(AMaxLen: Integer): String; var s, e: PChar; Len: Integer; begin GetFirstLastChar(s,e); if e <> nil then Len := e - s + 1 else Len := min(AMaxLen, 10); if (AMaxLen > 0) and (Len > AMaxLen) then Len := AMaxLen; Result := Copy(s, 1, Len); 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.GetFirstLastChar(out AFirst, ALast: PChar); begin inherited GetFirstLastChar(AFirst, ALast); if (FFullEndChar <> nil) and ( (FFullEndChar > ALast) or (ALast = nil)) then ALast := FFullEndChar; end; procedure TFpPascalExpressionPartBracket.CheckBeforeSeparator(APart: TFpPascalExpressionPart); begin if APart = nil then exit; FIsSeparatorChecking := True; APart.HandleEndOfExpression; FIsSeparatorChecking := False; end; procedure TFpPascalExpressionPartBracket.Assign(ASourcePart: TFpPascalExpressionPart); var ABracketSourcePart: TFpPascalExpressionPartBracket absolute ASourcePart; begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartBracket then begin FIsClosed := ABracketSourcePart.FIsClosed; FIsClosing := ABracketSourcePart.FIsClosing; FFullEndChar := ABracketSourcePart.FFullEndChar; end; end; procedure TFpPascalExpressionPartBracket.CloseBracket(ALastAddedPart: TFpPascalExpressionPart; APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar); begin FFullEndChar := AnEndChar; if AfterComma then begin SetError(fpErrPasParserMissingExprAfterComma, [GetText(MAX_ERR_EXPR_QUOTE_LEN), GetPos]); exit; end; FIsClosing := True; if ALastAddedPart <> nil then ALastAddedPart.HandleEndOfExpression; FIsClosing := False; FIsClosed := True; end; function TFpPascalExpressionPartBracket.HandleNextPart(APart: TFpPascalExpressionPart): TFpPascalExpressionPart; begin if IsClosed then begin Result := inherited HandleNextPart(APart); exit; end; Result := HandleNextPartInBracket(APart); end; procedure TFpPascalExpressionPartBracket.HandleEndOfExpression; begin if not (FIsClosing or FIsSeparatorChecking) then inherited HandleEndOfExpression; end; function TFpPascalExpressionPartBracket.IsClosed: boolean; begin Result := FIsClosed; 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; var APart: TFpPascalExpressionPart): Boolean; begin Result := HasAllOperands and (inherited HandleSeparator(ASeparatorType, APart)); 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; if Result then Result := IsValidAfterPartWithPrecedence(APrevPart); end; function TFpPascalExpressionPartBinaryOperator.IsValidAfterPartWithPrecedence( APrevPart: TFpPascalExpressionPart): Boolean; begin Result := True; (* BinaryOperator... # (e.g. Self = "+") # APrevPart = Identifier # APrevPart.Parent = "*" or "-" foo * Identifier + foo - Identifier + The binary-op "+" after "Identifier" must be applied to the parent. So, if SELF is the "+", then it is not valid after "Identifier". If new operator has a higher precedence, it go down to the child again and replace it *) // precedence: 1 = highest Result := (APrevPart.Parent = nil) or not (APrevPart.Parent.HasPrecedence) or (Precedence < APrevPart.Parent.Precedence) end; function TFpPascalExpressionPartBinaryOperator.HandleNextPart(APart: TFpPascalExpressionPart ): TFpPascalExpressionPart; begin if Count = 0 then SetError('Missing operand'); Result := inherited HandleNextPart(APart); 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: TFpValue; var tmp: TFpValue; begin Result := nil; if Count <> 1 then exit; tmp := Items[0].ResultValue; if (tmp = nil) or not IsTargetAddr(tmp.Address) then begin SetError(fpErrAnyError, []); // seterror / cant take address exit; end; Result := TFpPasParserValueAddressOf.Create(tmp, Items[0]); {$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: TFpValue; var tmp: TFpValue; 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, Items[0]); {$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: TFpValue; var tmp: TFpValue; addr: TFpDbgMemLocation; 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) then begin addr := tmp.DerefAddress; if not IsAddress(addr) then begin SetErrorWithPos(fpErrCannotDeref_p, [Items[0].GetText(MAX_ERR_EXPR_QUOTE_LEN)]); end else if tmp.TypeInfo <> nil then begin Result := tmp.Member[0]; if Result = nil then begin SetErrorWithPos(fpErrCannotDeref_p, [Items[0].GetText(MAX_ERR_EXPR_QUOTE_LEN)]); SetError(fpInternalErr, [], ExpressionData.Error); // mark as internal error end else {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end else begin Result := TFpValueConstAddress.Create(addr); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end; end; end else if tmp is TFpValueConstNumber then begin addr := TargetLoc(tmp.AsCardinal); Result := TFpValueConstAddress.Create(addr); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; end //if tmp.Kind = skArray then // dynarray else begin Result := nil; SetErrorWithPos(fpErrCannotDeref_p, [Items[0].GetText(MAX_ERR_EXPR_QUOTE_LEN)]); 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: TFpValue; var tmp1: TFpValue; 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; skFloat: Result := tmp1; end; Result.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(nil, 'DoGetResultValue'){$ENDIF}; end else begin case tmp1.Kind of skPointer: ; skInteger: Result := TFpValueConstNumber.Create(-tmp1.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(-tmp1.AsCardinal, True); skFloat: Result := TFpValueConstFloat.Create(-tmp1.AsFloat); end; {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; {$POP} ForwardError(Result, tmp1); end; { TFpPascalExpressionPartOperatorQuestionMark } procedure TFpPascalExpressionPartOperatorQuestionMark.Init; begin FPrecedence := PRECEDENCE_QUEST_COLON; inherited Init; end; function TFpPascalExpressionPartOperatorQuestionMark.DoGetResultValue: TFpValue; var tmp: TFpValue; ff: TFpValueFieldFlags; b: Boolean; begin Result := nil; if (Count <> 2) or not (Items[1] is TFpPascalExpressionPartOperatorColon) or (TFpPascalExpressionPartOperatorColon(Items[1]).Count <> 2) then begin SetError('internal error ?:'); exit; end; tmp := Items[0].ResultValue; if (tmp = nil) then exit; ff := tmp.FieldFlags; if (ff * [svfBoolean] <> []) then b := tmp.AsBool else if (ff * [svfCardinal, svfOrdinal] <> []) then b := tmp.AsCardinal <> 0 else if (ff * [svfString, svfWideString] <> []) then b := Length(tmp.AsString) <> 0 else begin SetError('"?" needs an input than can be cast to bool'); exit; end; if b then Result := TFpPascalExpressionPartOperatorColon(Items[1]).Items[0].ResultValue else Result := TFpPascalExpressionPartOperatorColon(Items[1]).Items[1].ResultValue; if Result = nil then exit; Result.AddReference; end; function TFpPascalExpressionPartOperatorQuestionMark.FindLeftSideOperandByPrecedence( AnOperator: TFpPascalExpressionPartWithPrecedence): TFpPascalExpressionPart; begin Result := Self; if (not HasAllOperands) or (LastItem = nil) then begin Result := nil; exit end; (* If precedence is equal, APart can be - a : - we don't have one yet => Return from LastItem - we have a : => return self - a ? - => Return from LastItem *) if (Precedence = AnOperator.Precedence) then begin if (Count = 2) and (Items[1] is TFpPascalExpressionPartOperatorColon) and (AnOperator is TFpPascalExpressionPartOperatorColon) then Result := Self else Result := LastItem.FindLeftSideOperandByPrecedence(AnOperator); end else // precedence: 1 = highest if Precedence >= AnOperator.Precedence then Result := LastItem.FindLeftSideOperandByPrecedence(AnOperator); end; function TFpPascalExpressionPartOperatorQuestionMark.IsValidAfterPartWithPrecedence( APrevPart: TFpPascalExpressionPart): Boolean; begin Result := (APrevPart.Parent = nil) or not (APrevPart.Parent.HasPrecedence) or (Precedence <= APrevPart.Parent.Precedence); (* inherited only checks for "<" instead of "<=" Other operators at the same precedence must have the 2nd (in left to right reading order) operator become the parent, so that it executes the entire left operation first. ? : act as nested constructs. The right part is a nested operation Therefore at same precedence, the new "?" is valid after any ongoing ? or : *) end; procedure TFpPascalExpressionPartOperatorQuestionMark.DoHandleEndOfExpression; begin inherited DoHandleEndOfExpression; if (Count <> 2) or not(Items[1] is TFpPascalExpressionPartOperatorColon) then SetError('Missing ":"'); end; function TFpPascalExpressionPartOperatorQuestionMark.ReturnsVariant: boolean; begin Result := True; // TODO: compare types of each argument end; function TFpPascalExpressionPartOperatorQuestionMark.IsClosed: boolean; begin Result := (Count = 2) and (Items[1] is TFpPascalExpressionPartOperatorColon); end; { TFpPascalExpressionPartOperatorColon } procedure TFpPascalExpressionPartOperatorColon.Init; begin FPrecedence := PRECEDENCE_QUEST_COLON; inherited Init; end; function TFpPascalExpressionPartOperatorColon.DoGetResultValue: TFpValue; begin raise Exception.Create('invalid call to ":"'); Result := nil; end; function TFpPascalExpressionPartOperatorColon.FindLeftSideOperandByPrecedence( AnOperator: TFpPascalExpressionPartWithPrecedence): TFpPascalExpressionPart; begin Result := Self; if (not HasAllOperands) or (LastItem = nil) then begin Result := nil; exit end; (* If precedence is equal - a : => must be outer => return self - a ? => LastItem *) if (Precedence = AnOperator.Precedence) then begin if AnOperator is TFpPascalExpressionPartOperatorQuestionMark then Result := LastItem.FindLeftSideOperandByPrecedence(AnOperator) else Result := Self; end else // precedence: 1 = highest if Precedence > AnOperator.Precedence then Result := LastItem.FindLeftSideOperandByPrecedence(AnOperator); end; function TFpPascalExpressionPartOperatorColon.IsValidAfterPartWithPrecedence( APrevPart: TFpPascalExpressionPart): Boolean; var Prev: TFpPascalExpressionPartOperatorQuestionMark absolute APrevPart; begin Result := (APrevPart.Parent = nil) or not (APrevPart.Parent.HasPrecedence) or (Precedence <= APrevPart.Parent.Precedence); if not Result then exit; // A colon is valid only after a questionmark that does not yet have its ":" // Otherwise it belongs to an outer question mark Result := (APrevPart is TFpPascalExpressionPartOperatorQuestionMark) and ( (Prev.Count = 2) and not(Prev.Items[1] is TFpPascalExpressionPartOperatorColon) ) end; procedure TFpPascalExpressionPartOperatorColon.DoHandleEndOfExpression; begin inherited DoHandleEndOfExpression; FIsClosed := True; if not(Parent is TFpPascalExpressionPartOperatorQuestionMark) then SetError('No "?" for ":"'); end; function TFpPascalExpressionPartOperatorColon.IsClosed: boolean; begin Result := FIsClosed; end; { TFpPascalExpressionPartOperatorPlusMinus } procedure TFpPascalExpressionPartOperatorPlusMinus.Init; begin FPrecedence := PRECEDENCE_PLUS_MINUS; inherited Init; end; function TFpPascalExpressionPartOperatorPlusMinus.DoGetResultValue: TFpValue; {$PUSH}{$R-}{$Q-} function AddSubValueToPointer(APointerVal, AOtherVal: TFpValue; ADoSubtract: Boolean = False): TFpValue; var Idx, m: Int64; TmpVal: TFpValue; s1, s2: TFpDbgValueSize; begin Result := nil; case AOtherVal.Kind of skPointer: if ADoSubtract then begin if ( (APointerVal.TypeInfo = nil) or (APointerVal.TypeInfo.TypeInfo = nil) ) and ( (AOtherVal.TypeInfo = nil) or (AOtherVal.TypeInfo.TypeInfo = nil) ) then begin Idx := APointerVal.AsCardinal - AOtherVal.AsCardinal; Result := TFpValueConstNumber.Create(Idx, True); exit; end else if (APointerVal.TypeInfo <> nil) and (APointerVal.TypeInfo.TypeInfo <> nil) and (AOtherVal.TypeInfo <> nil) and (AOtherVal.TypeInfo.TypeInfo <> nil) and (APointerVal.TypeInfo.TypeInfo.Kind = AOtherVal.TypeInfo.TypeInfo.Kind) and (APointerVal.TypeInfo.TypeInfo.ReadSize(nil, s1)) and (AOtherVal.TypeInfo.TypeInfo.ReadSize(nil, s2)) and (s1 = s2) then begin TmpVal := APointerVal.Member[1]; if (TmpVal = nil) or (s1 <> (TmpVal.Address.Address - APointerVal.DerefAddress.Address)) then begin TmpVal.ReleaseReference; debugln(DBG_WARNINGS, 'Size mismatch for pointer math'); exit; end; TmpVal.ReleaseReference; Idx := APointerVal.AsCardinal - AOtherVal.AsCardinal; if SizeToFullBytes(s1) > 0 then begin m := Idx mod SizeToFullBytes(s1); Idx := Idx div SizeToFullBytes(s1); if m <> 0 then begin debugln(DBG_WARNINGS, 'Size mismatch for pointer math'); exit; end; end; Result := TFpValueConstNumber.Create(Idx, True); exit; end else exit; end else exit; 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) or (TmpVal = nil) then begin SetError('Error dereferencing'); // TODO: set correct error exit; end; Result := TFpPasParserValueAddressOf.Create(TmpVal, Self); TmpVal.ReleaseReference; end; function AddValueToInt(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skPointer: Result := AddSubValueToPointer(AOtherVal, AIntVal); skInteger: Result := TFpValueConstNumber.Create(AIntVal.AsInteger + AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(AIntVal.AsInteger + AOtherVal.AsCardinal, True); skFloat: Result := TFpValueConstFloat.Create(AIntVal.AsInteger + AOtherVal.AsFloat); else SetError('Addition not supported'); end; end; function AddValueToCardinal(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skPointer: Result := AddSubValueToPointer(AOtherVal, ACardinalVal); skInteger: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal + AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal + AOtherVal.AsCardinal, False); skFloat: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal + AOtherVal.AsFloat); else SetError('Addition not supported'); end; end; function AddValueToFloat(AFloatVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat + AOtherVal.AsFloat); else SetError('Addition not supported'); end; end; function ConcateCharData(ACharVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; if AOtherVal.FieldFlags * [svfString, svfWideString] <> [] then Result := TFpValueConstString.Create(ACharVal.AsString + AOtherVal.AsString) else SetError('Operation + not supported'); end; function AddSets(ASetVal, AOtherVal: TFpValue): TFpValue; var i, j: Integer; m, m2: TFpValue; f: TFpValueFieldFlags; r: Boolean; begin Result := nil; case AOtherVal.Kind of skSet: begin Result := TFpValueConstSet.Create; for i := 0 to ASetVal.MemberCount - 1 do begin m := ASetVal.Member[i]; TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; for i := 0 to AOtherVal.MemberCount - 1 do begin m := AOtherVal.Member[i]; j := ASetVal.MemberCount - 1; while j >= 0 do begin m2 := ASetVal.Member[j]; f := m.FieldFlags * m2.FieldFlags; if svfOrdinal in f then r := m.AsCardinal = m2.AsCardinal else if svfIdentifier in f then r := m.AsString = m2.AsString else r := False; m2.ReleaseReference; if r then break; dec(j); end; if j < 0 then TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; end; else SetError('Operator +: set union requires a set as 2nd operator'); end; end; function SubPointerFromValue(APointerVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; // Error end; function SubValueFromInt(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skPointer: Result := SubPointerFromValue(AOtherVal, AIntVal); skInteger: Result := TFpValueConstNumber.Create(AIntVal.AsInteger - AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(AIntVal.AsInteger - AOtherVal.AsCardinal, True); skFloat: Result := TFpValueConstFloat.Create(AIntVal.AsInteger - AOtherVal.AsFloat); else SetError('Subtraction not supported'); end; end; function SubValueFromCardinal(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skPointer: Result := SubPointerFromValue(AOtherVal, ACardinalVal); skInteger: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal - AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal - AOtherVal.AsCardinal, False); skFloat: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal - AOtherVal.AsFloat); else SetError('Subtraction not supported'); end; end; function SubValueFromFloat(AFloatVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat - AOtherVal.AsFloat); else SetError('Subtraction not supported'); end; end; function SubtractSets(ASetVal, AOtherVal: TFpValue): TFpValue; var i, j: Integer; m, m2: TFpValue; f: TFpValueFieldFlags; r: Boolean; begin Result := nil; case AOtherVal.Kind of skSet: begin Result := TFpValueConstSet.Create; for i := 0 to ASetVal.MemberCount - 1 do begin m := ASetVal.Member[i]; j := AOtherVal.MemberCount - 1; while j >= 0 do begin m2 := AOtherVal.Member[j]; f := m.FieldFlags * m2.FieldFlags; if svfOrdinal in f then r := m.AsCardinal = m2.AsCardinal else if svfIdentifier in f then r := m.AsString = m2.AsString else r := False; m2.ReleaseReference; if r then break; dec(j); end; if j < 0 then TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; end; else SetError('Operator -: set diff requires a set as 2nd operator'); end; end; {$POP} var tmp1, tmp2: TFpValue; 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 skInteger: Result := AddValueToInt(tmp1, tmp2); skCardinal: Result := AddValueToCardinal(tmp1, tmp2); skFloat: Result := AddValueToFloat(tmp1, tmp2); skPointer: begin // Pchar can concatenate with String. But not with other Pchar // Maybe allow optional: This does limit undetected/mis-detected strings if (tmp1.FieldFlags * [svfString, svfWideString] <> []) and (tmp2.Kind in [skString, skAnsiString, skWideString, skChar{, skWideChar}]) then Result := ConcateCharData(tmp1, tmp2) else Result := AddSubValueToPointer(tmp1, tmp2); end; skString, skAnsiString, skWideString, skChar{, skWideChar}: Result := ConcateCharData(tmp1, tmp2); skSet: Result := AddSets(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); skSet: Result := SubtractSets(tmp1, tmp2); end; end; ForwardError(Result, tmp1); ForwardError(Result, tmp2); {$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: TFpValue; {$PUSH}{$R-}{$Q-} function MultiplyIntWithValue(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(AIntVal.AsInteger * AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(AIntVal.AsInteger * AOtherVal.AsCardinal, True); skFloat: Result := TFpValueConstFloat.Create(AIntVal.AsInteger * AOtherVal.AsFloat); else SetError('Multiply not supported'); end; end; function MultiplyCardinalWithValue(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal * AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal * AOtherVal.AsCardinal, False); skFloat: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal * AOtherVal.AsFloat); else SetError('Multiply not supported'); end; end; function MultiplyFloatWithValue(AFloatVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat * AOtherVal.AsFloat); else SetError('Multiply not supported'); end; end; function MultiplySets(ASetVal, AOtherVal: TFpValue): TFpValue; var i, j: Integer; m, m2: TFpValue; f: TFpValueFieldFlags; r: Boolean; begin Result := nil; case AOtherVal.Kind of skSet: begin Result := TFpValueConstSet.Create; for i := 0 to ASetVal.MemberCount - 1 do begin m := ASetVal.Member[i]; j := AOtherVal.MemberCount - 1; while j >= 0 do begin m2 := AOtherVal.Member[j]; f := m.FieldFlags * m2.FieldFlags; if svfOrdinal in f then r := m.AsCardinal = m2.AsCardinal else if svfIdentifier in f then r := m.AsString = m2.AsString else r := False; m2.ReleaseReference; if r then break; dec(j); end; if j >= 0 then TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; end; else SetError('Operator *: set intersection requires a set as 2nd operator'); end; end; function FloatDivIntByValue(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(AIntVal.AsInteger / AOtherVal.AsFloat); else SetError('/ not supported'); end; end; function FloatDivCardinalByValue(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(ACardinalVal.AsCardinal / AOtherVal.AsFloat); else SetError('/ not supported'); end; end; function FloatDivFloatByValue(AFloatVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsInteger); skCardinal: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsCardinal); skFloat: Result := TFpValueConstFloat.Create(AFloatVal.AsFloat / AOtherVal.AsFloat); else SetError('/ not supported'); end; end; function NumDivIntByValue(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; if (AOtherVal.AsInteger = 0) then begin if (IsError(AOtherVal.LastError)) then Result := TFpValueConstNumber.Create(0) // just for the error else SetError('Division by zero'); end else case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(AIntVal.AsInteger div AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(AIntVal.AsInteger div AOtherVal.AsCardinal, True); else SetError('Div not supported'); end; end; function NumDivCardinalByValue(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; if (AOtherVal.AsInteger = 0) then begin if (IsError(AOtherVal.LastError)) then Result := TFpValueConstNumber.Create(0) // just for the error else SetError('Division by zero'); end else case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal div AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal div AOtherVal.AsCardinal, False); else SetError('Div not supported'); end; end; function NumModIntByValue(AIntVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; if (AOtherVal.AsInteger = 0) then begin if (IsError(AOtherVal.LastError)) then Result := TFpValueConstNumber.Create(0) // just for the error else SetError('Modulo by zero') end else case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(AIntVal.AsInteger mod AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(AIntVal.AsInteger mod AOtherVal.AsCardinal, True); else SetError('Div not supported'); end; end; function NumModCardinalByValue(ACardinalVal, AOtherVal: TFpValue): TFpValue; begin Result := nil; if (AOtherVal.AsInteger = 0) then begin if (IsError(AOtherVal.LastError)) then Result := TFpValueConstNumber.Create(0) // just for the error else SetError('Modulo by zero') end else case AOtherVal.Kind of skInteger: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal mod AOtherVal.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(ACardinalVal.AsCardinal mod AOtherVal.AsCardinal, False); else SetError('Mod not supported'); end; end; {$POP} var tmp1, tmp2: TFpValue; begin Result := nil; if Count <> 2 then exit; 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); skSet: Result := MultiplySets(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 CompareText(GetText, 'div') = 0 then begin case tmp1.Kind of skInteger: Result := NumDivIntByValue(tmp1, tmp2); skCardinal: Result := NumDivCardinalByValue(tmp1, tmp2); end; end else if CompareText(GetText, 'mod') = 0 then begin case tmp1.Kind of skInteger: Result := NumModIntByValue(tmp1, tmp2); skCardinal: Result := NumModCardinalByValue(tmp1, tmp2); end; end; ForwardError(Result, tmp1); ForwardError(Result, tmp2); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; { TFpPascalExpressionPartOperatorUnaryNot } procedure TFpPascalExpressionPartOperatorUnaryNot.Init; begin FPrecedence := PRECEDENCE_UNARY_NOT; inherited Init; end; function TFpPascalExpressionPartOperatorUnaryNot.DoGetResultValue: TFpValue; var tmp1: TFpValue; begin Result := nil; if Count <> 1 then exit; tmp1 := Items[0].ResultValue; if (tmp1 = nil) then exit; {$PUSH}{$R-}{$Q-} case tmp1.Kind of skInteger: Result := TFpValueConstNumber.Create(not tmp1.AsInteger, True); skCardinal: Result := TFpValueConstNumber.Create(not tmp1.AsCardinal, False); skBoolean: Result := TFpValueConstBool.Create(not tmp1.AsBool); end; {$POP} ForwardError(Result, tmp1); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; { TFpPascalExpressionPartOperatorAnd } procedure TFpPascalExpressionPartOperatorAnd.Init; begin FPrecedence := PRECEDENCE_AND; inherited Init; end; function TFpPascalExpressionPartOperatorAnd.DoGetResultValue: TFpValue; var tmp1, tmp2: TFpValue; begin Result := nil; if Count <> 2 then exit; tmp1 := Items[0].ResultValue; tmp2 := Items[1].ResultValue; if (tmp1 = nil) or (tmp2 = nil) then exit; {$PUSH}{$R-}{$Q-} case tmp1.Kind of skInteger: if tmp2.Kind = skInteger then Result := TFpValueConstNumber.Create(tmp1.AsInteger AND tmp2.AsInteger, True) else Result := TFpValueConstNumber.Create(tmp1.AsCardinal AND tmp2.AsCardinal, False); skCardinal: if tmp2.Kind in [skInteger, skCardinal] then Result := TFpValueConstNumber.Create(tmp1.AsCardinal AND tmp2.AsCardinal, False); skBoolean: if tmp2.Kind = skBoolean then {$PUSH}{$BOOLEVAL on} Result := TFpValueConstBool.Create(tmp1.AsBool AND tmp2.AsBool); {$POP} end; {$POP} ForwardError(Result, tmp1); ForwardError(Result, tmp2); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; { TFpPascalExpressionPartOperatorBitShift } procedure TFpPascalExpressionPartOperatorBitShift.Init; begin FPrecedence := PRECEDENCE_BIT_SHIFT; inherited Init; end; function TFpPascalExpressionPartOperatorBitShift.CheckOperators(out AVal, AShift: QWord): boolean; var tmp1, tmp2: TFpValue; begin Result := False; if Count <> 2 then exit; tmp1 := Items[0].ResultValue; tmp2 := Items[1].ResultValue; if (tmp1 = nil) or (tmp2 = nil) then exit; if not (tmp1.Kind in [skInteger, skCardinal]) then begin SetError(GetText + ' requires a numeric value as first operand'); exit; end; if not (tmp2.Kind in [skInteger, skCardinal]) then begin SetError(GetText + ' requires a numeric value as second operand'); exit; end; AVal := tmp1.AsCardinal; AShift := tmp2.AsCardinal; Result := True; end; { TFpPascalExpressionPartOperatorShr } function TFpPascalExpressionPartOperatorShr.DoGetResultValue: TFpValue; var AVal, AShift: QWord; begin Result := nil; if not CheckOperators(AVal, AShift) then exit; {$PUSH}{$R-}{$Q-} Result := TFpValueConstNumber.Create(AVal >> AShift, False); {$POP} ForwardError(Result, Items[0].ResultValue); ForwardError(Result, Items[1].ResultValue); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; { TFpPascalExpressionPartOperatorShl } function TFpPascalExpressionPartOperatorShl.DoGetResultValue: TFpValue; var AVal, AShift: QWord; begin Result := nil; if not CheckOperators(AVal, AShift) then exit; {$PUSH}{$R-}{$Q-} Result := TFpValueConstNumber.Create(AVal << AShift, False); {$POP} ForwardError(Result, Items[0].ResultValue); ForwardError(Result, Items[1].ResultValue); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; { TFpPascalExpressionPartOperatorOr } procedure TFpPascalExpressionPartOperatorOr.Init; begin FPrecedence := PRECEDENCE_OR; inherited Init; end; function TFpPascalExpressionPartOperatorOr.DoGetResultValue: TFpValue; var tmp1, tmp2: TFpValue; begin Result := nil; if Count <> 2 then exit; tmp1 := Items[0].ResultValue; tmp2 := Items[1].ResultValue; if (tmp1 = nil) or (tmp2 = nil) then exit; {$PUSH}{$R-}{$Q-} case FOp of ootOr: case tmp1.Kind of skInteger: if tmp2.Kind in [skInteger, skCardinal] then Result := TFpValueConstNumber.Create(tmp1.AsInteger OR tmp2.AsInteger, True); skCardinal: if tmp2.Kind = skInteger then Result := TFpValueConstNumber.Create(tmp1.AsInteger OR tmp2.AsInteger, True) else if tmp2.Kind = skCardinal then Result := TFpValueConstNumber.Create(tmp1.AsInteger OR tmp2.AsInteger, False); skBoolean: if tmp2.Kind = skBoolean then {$PUSH}{$BOOLEVAL on} Result := TFpValueConstBool.Create(tmp1.AsBool OR tmp2.AsBool); {$POP} end; ootXor: case tmp1.Kind of skInteger: if tmp2.Kind in [skInteger, skCardinal] then Result := TFpValueConstNumber.Create(tmp1.AsInteger XOR tmp2.AsInteger, True); skCardinal: if tmp2.Kind = skInteger then Result := TFpValueConstNumber.Create(tmp1.AsInteger XOR tmp2.AsInteger, True) else if tmp2.Kind = skCardinal then Result := TFpValueConstNumber.Create(tmp1.AsInteger XOR tmp2.AsInteger, False); skBoolean: if tmp2.Kind = skBoolean then {$PUSH}{$BOOLEVAL on} Result := TFpValueConstBool.Create(tmp1.AsBool XOR tmp2.AsBool); {$POP} end; end; {$POP} ForwardError(Result, tmp1); ForwardError(Result, tmp2); {$IFDEF WITH_REFCOUNT_DEBUG}if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} end; procedure TFpPascalExpressionPartOperatorOr.Assign(ASourcePart: TFpPascalExpressionPart); begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartOperatorOr then FOp := TFpPascalExpressionPartOperatorOr(ASourcePart).FOp; end; constructor TFpPascalExpressionPartOperatorOr.Create( AnExpressionData: TFpPascalExpressionSharedData; AnOp: TOpOrType; AStartChar: PChar; AnEndChar: PChar); begin inherited Create(AnExpressionData, AStartChar, AnEndChar); FOp := AnOp; end; { TFpPascalExpressionPartOperatorCompare } procedure TFpPascalExpressionPartOperatorCompare.Init; begin FPrecedence := PRECEDENCE_COMPARE; inherited Init; end; function TFpPascalExpressionPartOperatorCompare.DoGetResultValue: TFpValue; {$PUSH}{$R-}{$Q-} function IntEqualToValue(AIntVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AIntVal.AsInteger = AOtherVal.AsFloat) xor AReverse); skPointer, skAddress: Result := TFpValueConstBool.Create((AIntVal.AsCardinal = AOtherVal.AsCardinal) xor AReverse) else SetError('= not supported'); end; end; function CardinalEqualToValue(ACardinalVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsFloat) xor AReverse); skPointer, skAddress: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal = AOtherVal.AsCardinal) xor AReverse) else SetError('= not supported'); end; end; function FloatEqualToValue(AFloatVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AFloatVal.AsFloat = AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function AddressPtrEqualToValue(AIntVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.Kind in [skClass,skInterface,skAddress,skPointer]) or ((AIntVal.Kind in [skPointer, skAddress]) and (AOtherVal.Kind in [skInteger,skCardinal])) then Result := TFpValueConstBool.Create((AIntVal.AsCardinal = AOtherVal.AsCardinal) xor AReverse) else SetError('= not supported'); end; function CharDataEqualToValue(ACharVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.FieldFlags * [svfString, svfWideString] <> []) then Result := TFpValueConstBool.Create((ACharVal.AsString = AOtherVal.AsString) xor AReverse) else SetError('= not supported'); end; function SetEqual(ASetVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; var r: TStringList; i: Integer; m: TFpValue; s: String; begin Result := nil; if AOtherVal.Kind <> skSet then begin SetError(GetText + ' not supported'); exit; end; r := TStringList.Create; try r.CaseSensitive := False; for i := 0 to ASetVal.MemberCount - 1 do begin m := ASetVal.Member[i]; s := m.AsString; m.ReleaseReference; if r.IndexOf(s) < 0 then r.Add(s); end; r.Sorted := True; for i := 0 to AOtherVal.MemberCount - 1 do begin m := AOtherVal.Member[i]; s := m.AsString; m.ReleaseReference; if r.IndexOf(s) < 0 then begin Result := TFpValueConstBool.Create(AReverse); exit; end; end; Result := TFpValueConstBool.Create(not AReverse); finally r.Free; end; end; function BoolEqual(ABoolVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.Kind = skBoolean) then Result := TFpValueConstBool.Create((ABoolVal.AsBool = AOtherVal.AsBool) xor AReverse) else SetError('= not supported'); end; function CheckEnumCompatible(AName: String; AExpVal: Integer; AnEnum: TFpValue): boolean; var m, t: TFpSymbol; begin Result := AName = ''; // un-named / maybe invalid ordinal value if Result then exit; t := AnEnum.TypeInfo; Result := t = nil; if Result then // TODO: TFpValueDwarfEnumMember currently does not have type info exit; m := t.NestedSymbolByName[AName]; Result := m <> nil; if not Result then exit; Result := m.HasOrdinalValue and (m.OrdinalValue = AExpVal); end; function EnumEqual(AnEnumVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.Kind in [skEnum, skEnumValue]) and (AnEnumVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) and (AOtherVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) then begin if CheckEnumCompatible(AnEnumVal.AsString, AnEnumVal.AsInteger, AOtherVal) and CheckEnumCompatible(AOtherVal.AsString, AOtherVal.AsInteger, AnEnumVal) then Result := TFpValueConstBool.Create((AnEnumVal.AsInteger = AOtherVal.AsInteger) xor AReverse) else SetError('type mismatch between enum'); end else SetError('= not supported'); end; function IntGreaterThanValue(AIntVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AIntVal.AsInteger > AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function CardinalGreaterThanValue(ACardinalVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal > AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function FloatGreaterThanValue(AFloatVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AFloatVal.AsFloat > AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function CharDataGreaterThanValue(ACharVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.FieldFlags * [svfString, svfWideString] <> []) then Result := TFpValueConstBool.Create((ACharVal.AsString > AOtherVal.AsString) xor AReverse) else SetError('= not supported'); end; function EnumGreaterThanValue(AnEnumVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.Kind in [skEnum, skEnumValue]) and (AnEnumVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) and (AOtherVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) then begin if CheckEnumCompatible(AnEnumVal.AsString, AnEnumVal.AsInteger, AOtherVal) and CheckEnumCompatible(AOtherVal.AsString, AOtherVal.AsInteger, AnEnumVal) then Result := TFpValueConstBool.Create((AnEnumVal.AsInteger > AOtherVal.AsInteger) xor AReverse) else SetError('type mismatch between enum'); end else SetError(GetText+' not supported'); end; function IntSmallerThanValue(AIntVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AIntVal.AsInteger < AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function CardinalSmallerThanValue(ACardinalVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((ACardinalVal.AsCardinal < AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function FloatSmallerThanValue(AFloatVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; case AOtherVal.Kind of skInteger: Result := TFpValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsInteger) xor AReverse); skCardinal: Result := TFpValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsCardinal) xor AReverse); skFloat: Result := TFpValueConstBool.Create((AFloatVal.AsFloat < AOtherVal.AsFloat) xor AReverse); else SetError('= not supported'); end; end; function CharDataSmallerThanValue(ACharVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.FieldFlags * [svfString, svfWideString] <> []) then Result := TFpValueConstBool.Create((ACharVal.AsString < AOtherVal.AsString) xor AReverse) else SetError('= not supported'); end; function EnumSmallerThanValue(AnEnumVal, AOtherVal: TFpValue; AReverse: Boolean = False): TFpValue; begin Result := nil; if (AOtherVal.Kind in [skEnum, skEnumValue]) and (AnEnumVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) and (AOtherVal.FieldFlags * [svfInteger, svfCardinal, svfOrdinal] <> []) then begin if CheckEnumCompatible(AnEnumVal.AsString, AnEnumVal.AsInteger, AOtherVal) and CheckEnumCompatible(AOtherVal.AsString, AOtherVal.AsInteger, AnEnumVal) then Result := TFpValueConstBool.Create((AnEnumVal.AsInteger < AOtherVal.AsInteger) xor AReverse) else SetError('type mismatch between enum'); end else SetError(GetText+' not supported'); end; function SymDiffSets(ASetVal, AOtherVal: TFpValue): TFpValue; var i, j: Integer; m, m2: TFpValue; f: TFpValueFieldFlags; r: Boolean; begin Result := TFpValueConstSet.Create; for i := 0 to ASetVal.MemberCount - 1 do begin m := ASetVal.Member[i]; j := AOtherVal.MemberCount - 1; while j >= 0 do begin m2 := AOtherVal.Member[j]; f := m.FieldFlags * m2.FieldFlags; if svfOrdinal in f then r := m.AsCardinal = m2.AsCardinal else if svfIdentifier in f then r := m.AsString = m2.AsString else r := False; m2.ReleaseReference; if r then break; dec(j); end; if j < 0 then TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; for i := 0 to AOtherVal.MemberCount - 1 do begin m := AOtherVal.Member[i]; j := ASetVal.MemberCount - 1; while j >= 0 do begin m2 := ASetVal.Member[j]; f := m.FieldFlags * m2.FieldFlags; if svfOrdinal in f then r := m.AsCardinal = m2.AsCardinal else if svfIdentifier in f then r := m.AsString = m2.AsString else r := False; m2.ReleaseReference; if r then break; dec(j); end; if j < 0 then TFpValueConstSet(Result).AddVal(m); m.ReleaseReference; end; end; {$POP} var tmp1, tmp2: TFpValue; 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 = '<>')); skPointer: begin // Pchar can concatenate with String. But not with other Pchar // Maybe allow optional: This does limit undetected/mis-detected strings if (tmp1.FieldFlags * [svfString, svfWideString] <> []) and (tmp2.Kind in [skString, skAnsiString, skWideString, skChar{, skWideChar}]) then Result := CharDataEqualToValue(tmp1, tmp2, (s = '<>')) else Result := AddressPtrEqualToValue(tmp1, tmp2, (s = '<>')); end; skClass,skInterface: Result := AddressPtrEqualToValue(tmp1, tmp2, (s = '<>')); skAddress: begin if tmp2.Kind in [skClass,skInterface,skPointer,skAddress] then Result := AddressPtrEqualToValue(tmp1, tmp2, (s = '<>')); end; skString, skAnsiString, skWideString, skChar{, skWideChar}: Result := CharDataEqualToValue(tmp1, tmp2, (s = '<>')); skSet: Result := SetEqual(tmp1, tmp2, (s = '<>')); skBoolean: Result := BoolEqual(tmp1, tmp2, (s = '<>')); skEnum, skEnumValue: Result := EnumEqual(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 = '<=')); skPointer: if (tmp1.FieldFlags * [svfString, svfWideString] <> []) and (tmp2.Kind in [skString, skAnsiString, skWideString, skChar{, skWideChar}]) then Result := CharDataGreaterThanValue(tmp1, tmp2, (s = '<=')); skString, skAnsiString, skWideString, skChar{, skWideChar}: Result := CharDataGreaterThanValue(tmp1, tmp2, (s = '<=')); skEnum, skEnumValue: Result := EnumGreaterThanValue(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 = '>=')); skPointer: if (tmp1.FieldFlags * [svfString, svfWideString] <> []) and (tmp2.Kind in [skString, skAnsiString, skWideString, skChar{, skWideChar}]) then Result := CharDataSmallerThanValue(tmp1, tmp2, (s = '>=')); skString, skAnsiString, skWideString, skChar{, skWideChar}: Result := CharDataSmallerThanValue(tmp1, tmp2, (s = '>=')); skEnum, skEnumValue: Result := EnumSmallerThanValue(tmp1, tmp2, (s = '>=')); end; end else if GetText = '><' then begin if (tmp1.Kind = skSet) and (tmp2.Kind = skSet) then Result := SymDiffSets(tmp1, tmp2); end; ForwardError(Result, tmp1); ForwardError(Result, tmp2); {$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: TFpValue; var tmp, AutoDereVal: TFpValue; MemberName: String; MemberSym: TFpSymbol; begin Result := nil; if Count <> 2 then exit; tmp := Items[0].ResultValue; if (tmp = nil) then exit; MemberName := Items[1].GetText; AutoDereVal := nil; try if ExpressionData.AutoDeref then begin // Copy from TFpPascalExpressionPartOperatorDeRef.DoGetResultValue if tmp.Kind = skPointer then begin if (svfDataAddress in tmp.FieldFlags) and (IsReadableLoc(tmp.DerefAddress)) and // TODO, what if Not readable addr (tmp.TypeInfo <> nil) //and (tmp.TypeInfo.TypeInfo <> nil) then begin tmp := tmp.Member[0]; AutoDereVal := tmp; end; if (tmp = nil) then begin SetErrorWithPos(fpErrCannotDeref_p, [Items[0].GetText(MAX_ERR_EXPR_QUOTE_LEN)]); exit; end; end; end; if (tmp.Kind in [skClass, skInterface, skRecord, skObject]) then begin Result := tmp.MemberByName[MemberName]; if Result = nil then begin SetError(fpErrNoMemberWithName, [MemberName]); exit; end; {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; Assert((Result.DbgSymbol=nil)or(Result.DbgSymbol.SymbolType=stValue), 'member is value'); exit; end; finally AutoDereVal.ReleaseReference; end; if (tmp.Kind in [skType]) and (tmp.DbgSymbol <> nil) and (tmp.DbgSymbol.Kind in [skClass, skInterface, skRecord, skObject]) then begin Result := tmp.MemberByName[MemberName]; if Result <> nil then begin // only class fields/constants can have an address without valid "self" instance if IsReadableLoc(result.DataAddress) then begin // result.Address? {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; exit; end else begin ReleaseRefAndNil(Result); MemberSym := tmp.DbgSymbol.NestedSymbolByName[MemberName]; if MemberSym <> nil then begin Result := TFpValueTypeDefinition.Create(MemberSym); {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; exit; end; end; end; SetError(fpErrNoMemberWithName, [MemberName]); exit end; if (tmp.Kind in [skType]) and (tmp.DbgSymbol <> nil) and (tmp.DbgSymbol.Kind in [skEnum]) then begin Result := tmp.MemberByName[MemberName]; if Result <> nil then begin {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; exit; end; SetError(fpErrNoMemberWithName, [MemberName]); exit end; if (tmp.Kind = skUnit) or ( (tmp.DbgSymbol <> nil) and (tmp.DbgSymbol.Kind = skUnit) ) then begin (* If a class/record/object matches the typename, but did not have the member, then this could still be a unit. If the class/record/object is in the same unit as the current contexct (selected function) then it would hide the unitname, but otherwise a unit in the uses clause would hide the structure. *) Result := ExpressionData.Scope.FindSymbol(MemberName, Items[0].GetText); if Result <> nil then begin {$IFDEF WITH_REFCOUNT_DEBUG}Result.DbgRenameReference(nil, 'DoGetResultValue'){$ENDIF}; exit; end; end; SetError(fpErrorNotAStructure, [MemberName, Items[0].GetText]); end; { TFpPascalExpressionPartOperatorMemberIn } procedure TFpPascalExpressionPartOperatorMemberIn.Init; begin FPrecedence := PRECEDENCE_IN; inherited Init; end; function TFpPascalExpressionPartOperatorMemberIn.DoGetResultValue: TFpValue; var AVal, ASet, m: TFpValue; s: String; i: Integer; f, af: TFpValueFieldFlags; r: Boolean; v: QWord; begin Result := nil; if Count <> 2 then begin SetError('"in" requires 2 values'); exit; end; ASet := Items[1].ResultValue; if (ASet = nil) or (ASet.Kind <> skSet) then begin SetError('"in" requires a set'); exit; end; AVal := Items[0].ResultValue; if AVal = nil then begin SetError('"in" requires an enum'); exit; end; if (AVal.Kind in [skEnum, skEnumValue]) then begin s := ''; v := 0; af := AVal.FieldFlags; if svfIdentifier in af then s := LowerCase(AVal.AsString); if svfOrdinal in af then v := AVal.AsCardinal; r := False; for i := 0 to ASet.MemberCount-1 do begin m := ASet.Member[i]; f := m.FieldFlags * af; if svfIdentifier in f then r := LowerCase(m.AsString) = s else if svfOrdinal in f then r := m.AsCardinal = v else r := False; m.ReleaseReference; if r then break; end; Result := TFpValueConstBool.Create(r); {$IFDEF WITH_REFCOUNT_DEBUG} if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} exit; end; if (AVal.Kind in [skChar, skSimple, skCardinal, skInteger]) and (svfOrdinal in AVal.FieldFlags) then begin v := AVal.AsCardinal; r := False; for i := 0 to ASet.MemberCount-1 do begin m := ASet.Member[i]; f := m.FieldFlags; if svfOrdinal in m.FieldFlags then r := m.AsCardinal = v else r := False; m.ReleaseReference; if r then break; end; Result := TFpValueConstBool.Create(r); {$IFDEF WITH_REFCOUNT_DEBUG} if Result <> nil then Result.DbgRenameReference(nil, 'DoGetResultValue');{$ENDIF} exit; end; SetError('"in" requires an enum'); end; { TFpPasParserValueSlicedArrayIndex } function TFpPasParserValueSlicedArrayIndex.GetValueLowBound( AValueObj: TFpValue; out ALowBound: Int64): Boolean; begin ALowBound := FLowBound; Result := True; end; { TFpPasParserValueSlicedArray } function TFpPasParserValueSlicedArray.SlicePart: TFpPascalExpressionPartOperatorArraySlice; begin Result := FArraySlice.FSlicePart; end; function TFpPasParserValueSlicedArray.GetKind: TDbgSymbolKind; begin Result := skArray; end; function TFpPasParserValueSlicedArray.GetFieldFlags: TFpValueFieldFlags; begin Result := [svfMembers]; end; function TFpPasParserValueSlicedArray.GetTypeInfo: TFpSymbol; begin Result := nil; end; function TFpPasParserValueSlicedArray.GetMember(AIndex: Int64): TFpValue; begin if SlicePart.FCurrentIndex <> AIndex then begin SlicePart.FCurrentIndex := AIndex; FArraySlice.ResetEvaluationForIndex; // Some evaluation errors (such as deref nil) are marked on the Expression, // rather than on the value(s). // If this code is called, the Expression should have been valid before. FExpressionPartInValue.ExpressionData.ClearError; end; Result := FArraySlice.Items[0].ResultValue; if Result <> nil then begin //if IsError(FExpressionPart.ExpressionData.FError) and not IsError(Result.LastError) then // Result.SetLastError(FExpressionPart.ExpressionData.FError); Result.AddReference; Result.Reset; if FArraySlice.FHasVariantPart then Result.Flags := Result.Flags + [vfVariant]; end; FExpressionPartInValue.ExpressionData.ClearError; end; function TFpPasParserValueSlicedArray.GetMemberCount: Integer; begin Result := SlicePart.EndValue - SlicePart.StartValue + 1; end; function TFpPasParserValueSlicedArray.GetIndexType(AIndex: Integer): TFpSymbol; begin Result := FLowBoundIndex; end; function TFpPasParserValueSlicedArray.GetIndexTypeCount: Integer; begin Result := 1; end; function TFpPasParserValueSlicedArray.GetOrdLowBound: Int64; begin Result := FLowBoundIndex.FLowBound; end; constructor TFpPasParserValueSlicedArray.Create( ASlice: TFpPascalExpressionPartOperatorArraySliceController; AnOwnsController: boolean); begin FExpressionPartInValue := ASlice; inherited Create(ASlice); FArraySlice := ASlice; FOwnsController := AnOwnsController; FLowBoundIndex := TFpPasParserValueSlicedArrayIndex.Create(''); FLowBoundIndex.FLowBound := SlicePart.StartValue; end; destructor TFpPasParserValueSlicedArray.Destroy; begin inherited Destroy; FLowBoundIndex.ReleaseReference; if FOwnsController then FArraySlice.Free; end; function TFpPasParserValueSlicedArray.SliceBracketStartOffs: integer; var sp: TFpPascalExpressionPartOperatorArraySlice; s, e: PChar; begin Result := -1; sp := SlicePart; if (sp <> nil) then begin sp.GetFirstLastChar(s, e); Result := s - sp.ExpressionData.TextExpressionAddr + 1; end; end; function TFpPasParserValueSlicedArray.SliceBracketLength: integer; var sp: TFpPascalExpressionPartOperatorArraySlice; s, e: PChar; begin Result := -1; sp := SlicePart; if (sp <> nil) then begin sp.GetFirstLastChar(s, e); while e[1] = '!' do e := e + 1; Result := e - s + 1; end; end; { TFpPascalExpressionPartOperatorArraySliceController } function TFpPascalExpressionPartOperatorArraySliceController.GetFullText(AMaxLen: Integer): String; begin Result := ''; if Count > 0 then Result := Items[0].GetFullText(AMaxLen); end; function TFpPascalExpressionPartOperatorArraySliceController.DebugText(AIndent: String; AWithResults: Boolean): String; begin Result := inherited DebugText(AIndent, AWithResults) + AIndent +'// '+ GetFullText+LineEnding; end; function TFpPascalExpressionPartOperatorArraySliceController.GetCanDisableSlice: boolean; begin Result := (not FResultValDone); end; function TFpPascalExpressionPartOperatorArraySliceController.DoGetResultValue: TFpValue; var me: TFpPascalExpressionPartOperatorArraySliceController; begin if FNeedCopy > 0 then me := TFpPascalExpressionPartOperatorArraySliceController(CreateCopy(Parent)) else me := Self; Result := me.InternalDoGetResultValue(FNeedCopy > 0); end; function TFpPascalExpressionPartOperatorArraySliceController.InternalDoGetResultValue( ANeedCopy: boolean): TFpValue; var tmp: TFpValue; begin FSlicePart.FCurrentIndex := FSlicePart.StartValue; FSlicePart.EndValue; // needs to be touched FSlicePart.FTouched := False; ResetEvaluationForIndex; Result := Items[0].ResultValue; if (not FSlicePart.FTouched) or DisableSlice then begin // The array slice is not part of the ExpressionData ("? :" or Try) // Or already handled. if Result <> nil then Result.AddReference; if ANeedCopy then Self.Free; exit; end; if (FSlicePart.Parent.Items[0].ResultValue <> nil) then begin tmp := FSlicePart.Parent.Items[0].ResultValue; if (vfArrayUpperBoundLimit in tmp.Flags) then begin FSlicePart.FUpperLimit := tmp.OrdHighBound; FSlicePart.FHasUpperLimit := True; end; end; // Need to return an array, the array itself should not set an error (the 1st (or any) member may do) // We need to get the error again later, when we get the first member if IsError(ExpressionData.Error) then Items[0].ResetEvaluation; ExpressionData.ClearError; if not FCheckedForVariantPart then begin FSlicePart.CheckForVariantExpressionParts; FCheckedForVariantPart := True; end; Result := TFpPasParserValueSlicedArray.Create(Self, ANeedCopy); if FHasVariantPart then Result.Flags := Result.Flags + [vfArrayOfVariant]; end; procedure TFpPascalExpressionPartOperatorArraySliceController.DoParentIndexBraceClosed( APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); begin if Count = 1 then Items[0].DoParentIndexBraceClosed(APreviousArraySliceList); end; procedure TFpPascalExpressionPartOperatorArraySliceController.ResetEvaluation; begin inherited ResetEvaluation; FDisableSlice := False; end; procedure TFpPascalExpressionPartOperatorArraySliceController.ResetEvaluationForIndex; begin FInResetEvaluationForIndex := True; FSlicePart.ResetEvaluationForAnchestors; FInResetEvaluationForIndex := False; end; procedure TFpPascalExpressionPartOperatorArraySliceController.ResetEvaluationForAnchestors; begin if FInResetEvaluationForIndex then exit; inherited ResetEvaluationForAnchestors; end; constructor TFpPascalExpressionPartOperatorArraySliceController.Create( AnExpressionData: TFpPascalExpressionSharedData; ASlicePart: TFpPascalExpressionPartOperatorArraySlice; AStartChar: PChar; AnEndChar: PChar); begin inherited Create(AnExpressionData, AStartChar, AnEndChar); FSlicePart := ASlicePart; FIsClosed := True; end; procedure TFpPascalExpressionPartOperatorArraySliceController.BeginNeedCopy; begin inherited BeginNeedCopy; inc(FNeedCopy); end; procedure TFpPascalExpressionPartOperatorArraySliceController.EndNeedCopy; begin inherited EndNeedCopy; dec(FNeedCopy); end; { TFpPascalExpressionPartOperatorArraySlice } procedure TFpPascalExpressionPartOperatorArraySlice.Init; begin inherited Init; FPrecedence := PRECEDENCE_ARRAY_SLICE; end; procedure TFpPascalExpressionPartOperatorArraySlice.DoParentIndexBraceClosed( APreviousArraySliceList: PFpPascalExpressionPartOperatorArraySlice); var p, p2: TFpPascalExpressionPartOperatorArraySlice; begin FPreviousArraySlice := APreviousArraySliceList^; APreviousArraySliceList^ := Self; if FindInParents(FPreviousArraySlice) then begin p := FPreviousArraySlice; p2 := p.FPreviousArraySlice; while FindInParents(p2) do begin p := p2; p2 := p.FPreviousArraySlice; end; if APreviousArraySliceList^ = Self then begin APreviousArraySliceList^ := p; end else begin p2 := APreviousArraySliceList^; while p2.FPreviousArraySlice <> self do p2 := p2.FPreviousArraySlice; p2.FPreviousArraySlice := p; end; FPreviousArraySlice := p.FPreviousArraySlice; p.FPreviousArraySlice := Self; end; end; function TFpPascalExpressionPartOperatorArraySlice.DoGetResultValue: TFpValue; begin FTouched := True; Result := TFpValueConstNumber.Create(QWord(FCurrentIndex), True); end; function TFpPascalExpressionPartOperatorArraySlice.StartValue: Int64; var tmp: TFpValue; begin Result := 0; if Count < 1 then exit; tmp := Items[0].ResultValue; if tmp <> nil then Result := tmp.AsInteger; end; function TFpPascalExpressionPartOperatorArraySlice.EndValue: Int64; var tmp: TFpValue; i: Int64; begin Result := 0; if Count < 2 then exit; tmp := Items[1].ResultValue; if tmp <> nil then begin Result := tmp.AsInteger; if FHasUpperLimit and (FUpperLimit < Result) then Result := FUpperLimit; end; end; procedure TFpPascalExpressionPartOperatorArraySlice.CheckForVariantExpressionParts; var AHasVariantPart: Boolean; APart: TFpPascalExpressionPartContainer; begin AHasVariantPart := False; APart := Parent; while (APart <> nil) and not(APart is TFpPascalExpressionPartOperatorArraySliceController) do begin if APart.ReturnsVariant then AHasVariantPart := True; APart := APart.Parent; end; // The most inner TFpPascalExpressionPartOperatorArraySliceController, even if not belonging to this slice if APart is TFpPascalExpressionPartOperatorArraySliceController then TFpPascalExpressionPartOperatorArraySliceController(APart).FHasVariantPart := AHasVariantPart; end; procedure TFpPascalExpressionPartOperatorArraySlice.Assign(ASourcePart: TFpPascalExpressionPart); var SliceSourcePart: TFpPascalExpressionPartOperatorArraySlice absolute ASourcePart; begin inherited Assign(ASourcePart); if ASourcePart is TFpPascalExpressionPartOperatorArraySlice then begin FController := TFpPascalExpressionPartOperatorArraySliceController(FindCopiedInParents(ASourcePart, SliceSourcePart.FController)); if FController <> nil then FController.FSlicePart := Self else FController := SliceSourcePart.FController; end; end; destructor TFpPascalExpressionPartOperatorArraySlice.Destroy; begin if (FController <> nil) and (FController.SlicePart = Self) then FController.FSlicePart := nil; // in case of DebugDump inherited Destroy; end; function TFpPascalExpressionPartOperatorArraySlice.IsClosed: boolean; begin Result := (Parent <> nil) and (Parent is TFpPascalExpressionPartBracketIndex) and Parent.IsClosed; // the enclosing index brackets "[ ]" end; function TFpPascalExpressionPartOperatorArraySlice.AddController(ACurPart: TFpPascalExpressionPart ): TFpPascalExpressionPart; var p: TFpPascalExpressionPart; begin Result := ACurPart; if not ExpressionData.Valid then exit; if FController <> nil then exit; p := ACurPart; while (ACurPart.Parent <> nil) and ( ACurPart.Parent.IsClosed or not FindInParents(ACurPart) ) do ACurPart := ACurPart.Parent; FController := TFpPascalExpressionPartOperatorArraySliceController.Create(ExpressionData, Self, FStartChar, FEndChar); FController.Parent := ACurPart.Parent; ACurPart.ReplaceInParent(FController); p.HandleEndOfExpression; FController.Add(ACurPart); Result := FController; end; function TFpPascalExpressionPartOperatorArraySlice.AddControllerRecursive( ACurPart: TFpPascalExpressionPart): TFpPascalExpressionPart; begin Result := AddController(ACurPart); if not ExpressionData.Valid then exit; if FPreviousArraySlice <> nil then Result := FPreviousArraySlice.AddControllerRecursive(Result); end; initialization DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} ); end.