paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 05:39:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add support for currency type

Browse Source 
git-svn-id: trunk@38523 -
This commit is contained in:
michael 2018-03-14 10:54:42 +00:00
parent 3a78ff1ee4
commit c3414c6100
2 changed files with 597 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

445
packages/fcl-base/src/fpexprpars.pp
View File

@ -85,7 +85,7 @@ Type
EExprScanner = Class(Exception);
TResultType = (rtBoolean,rtInteger,rtFloat,rtDateTime,rtString);
TResultType = (rtBoolean,rtInteger,rtFloat,rtDateTime,rtString,rtCurrency);
TResultTypes = set of TResultType;
TFPExpressionResult = record
@ -94,6 +94,7 @@ Type
rtBoolean : (ResBoolean : Boolean);
rtInteger : (ResInteger : Int64);
rtFloat : (ResFloat : TExprFloat);
rtCurrency : (ResCurrency : Currency);
rtDateTime : (ResDateTime : TDatetime);
rtString : ();
end;
@ -389,12 +390,21 @@ Type
end;
{ TIntToFloatNode }
TIntToFloatNode = Class(TIntConvertNode)
Public
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TIntToCurrencyNode }
TIntToCurrencyNode = Class(TIntConvertNode)
Public
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TIntToDateTimeNode }
TIntToDateTimeNode = Class(TIntConvertNode)
@ -412,6 +422,34 @@ Type
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TFloatToCurrencyNode }
TFloatToCurrencyNode = Class(TFPConvertNode)
Public
Procedure Check; override;
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TCurrencyToDateTimeNode }
TCurrencyToDateTimeNode = Class(TFPConvertNode)
Public
Procedure Check; override;
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TCurrencyToFloatNode }
TCurrencyToFloatNode = Class(TFPConvertNode)
Public
Procedure Check; override;
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
end;
{ TFPNegateOperation }
TFPNegateOperation = Class(TFPUnaryOperator)
@ -433,6 +471,7 @@ Type
Constructor CreateDateTime(AValue : TDateTime);
Constructor CreateFloat(AValue : TExprFloat);
Constructor CreateBoolean(AValue : Boolean);
constructor CreateCurrency(AValue: Currency);
Procedure Check; override;
Function NodeType : TResultType; override;
Procedure GetNodeValue(var Result : TFPExpressionResult); override;
@ -465,6 +504,7 @@ Type
function GetAsBoolean: Boolean;
function GetAsDateTime: TDateTime;
function GetAsFloat: TExprFloat;
function GetAsCurrency : Currency;
function GetAsInteger: Int64;
function GetAsString: String;
function GetResultType: TResultType;
@ -473,6 +513,7 @@ Type
procedure SetAsBoolean(const AValue: Boolean);
procedure SetAsDateTime(const AValue: TDateTime);
procedure SetAsFloat(const AValue: TExprFloat);
procedure SetAsCurrency(const AValue: Currency);
procedure SetAsInteger(const AValue: Int64);
procedure SetAsString(const AValue: String);
procedure SetName(const AValue: ShortString);
@ -487,6 +528,7 @@ Type
Procedure Assign(Source : TPersistent); override;
Function EventBasedVariable : Boolean; Inline;
Property AsFloat : TExprFloat Read GetAsFloat Write SetAsFloat;
Property AsCurrency : Currency Read GetAsCurrency Write SetAsCurrency;
Property AsInteger : Int64 Read GetAsInteger Write SetAsInteger;
Property AsString : String Read GetAsString Write SetAsString;
Property AsBoolean : Boolean Read GetAsBoolean Write SetAsBoolean;
@ -539,6 +581,7 @@ Type
Function AddBooleanVariable(Const AName : ShortString; AValue : Boolean) : TFPExprIdentifierDef;
Function AddIntegerVariable(Const AName : ShortString; AValue : Integer) : TFPExprIdentifierDef;
Function AddFloatVariable(Const AName : ShortString; AValue : TExprFloat) : TFPExprIdentifierDef;
Function AddCurrencyVariable(Const AName : ShortString; AValue : Currency) : TFPExprIdentifierDef;
Function AddStringVariable(Const AName : ShortString; AValue : String) : TFPExprIdentifierDef;
Function AddDateTimeVariable(Const AName : ShortString; AValue : TDateTime) : TFPExprIdentifierDef;
Function AddFunction(Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ACallBack : TFPExprFunctionCallBack) : TFPExprIdentifierDef;
@ -576,6 +619,7 @@ Type
FargumentParams : TExprParameterArray;
Protected
Procedure CalcParams;
function ConvertArgument(aIndex: Integer; aNode: TFPExprNode; aType: TResultType): TFPExprNode; virtual;
Public
Procedure Check; override;
Constructor CreateFunction(AID : TFPExprIdentifierDef; Const Args : TExprArgumentArray); virtual;
@ -622,6 +666,7 @@ Type
TAggregateSum = Class(TAggregateExpr)
Public
function ConvertArgument(aIndex: Integer; aNode: TFPExprNode; aType: TResultType): TFPExprNode; override;
Procedure InitAggregate; override;
Procedure UpdateAggregate; override;
end;
@ -679,10 +724,10 @@ Type
FHashList : TFPHashObjectlist;
FDirty : Boolean;
procedure CheckEOF;
function ConvertNode(Todo: TFPExprNode; ToType: TResultType): TFPExprNode;
function GetAsBoolean: Boolean;
function GetAsDateTime: TDateTime;
function GetAsFloat: TExprFloat;
function GetAsCurrency: Currency;
function GetAsInteger: Int64;
function GetAsString: String;
function MatchNodes(Todo, Match: TFPExprNode): TFPExprNode;
@ -693,6 +738,8 @@ Type
procedure ParserError(Msg: String);
procedure SetExpression(const AValue: String); virtual;
Procedure CheckResultType(Const Res :TFPExpressionResult; AType : TResultType); inline;
Procedure CheckResultTypes(Const Res :TFPExpressionResult; ATypes : TResultTypes); inline;
Class function ConvertNode(Todo: TFPExprNode; ToType: TResultType): TFPExprNode;
class Function BuiltinsManager : TExprBuiltInManager;
Function Level1 : TFPExprNode;
Function Level2 : TFPExprNode;
@ -714,7 +761,7 @@ Type
Destructor Destroy; override;
Function IdentifierByName(const AName : ShortString) : TFPExprIdentifierDef; virtual;
Procedure Clear;
Procedure EvaluateExpression(Var Result : TFPExpressionResult);
Procedure EvaluateExpression(Out Result : TFPExpressionResult);
function ExtractNode(var N: TFPExprNode): Boolean;
Function Evaluate : TFPExpressionResult;
Function ResultType : TResultType;
@ -722,6 +769,7 @@ Type
Procedure InitAggregate;
Procedure UpdateAggregate;
Property AsFloat : TExprFloat Read GetAsFloat;
Property AsCurrency : Currency Read GetAsCurrency;
Property AsInteger : Int64 Read GetAsInteger;
Property AsString : String Read GetAsString;
Property AsBoolean : Boolean Read GetAsBoolean;
@ -752,6 +800,7 @@ Type
Function AddBooleanVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : Boolean) : TFPBuiltInExprIdentifierDef;
Function AddIntegerVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : Integer) : TFPBuiltInExprIdentifierDef;
Function AddFloatVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : TExprFloat) : TFPBuiltInExprIdentifierDef;
Function AddCurrencyVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : Currency) : TFPBuiltInExprIdentifierDef;
Function AddStringVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : String) : TFPBuiltInExprIdentifierDef;
Function AddDateTimeVariable(Const ACategory : TBuiltInCategory; Const AName : ShortString; AValue : TDateTime) : TFPBuiltInExprIdentifierDef;
Function AddFunction(Const ACategory : TBuiltInCategory; Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ACallBack : TFPExprFunctionCallBack) : TFPBuiltInExprIdentifierDef;
@ -877,6 +926,7 @@ begin
'B' : Result:=rtBoolean;
'I' : Result:=rtInteger;
'F' : Result:=rtFloat;
'C' : Result:=rtCurrency;
else
RaiseParserError(SErrInvalidResultCharacter,[C]);
end;
@ -899,6 +949,39 @@ begin
FreeAndNil(Builtins);
end;
{ TFloatToCurrencyNode }
procedure TFloatToCurrencyNode.Check;
begin
CheckNodeType(Operand,[rtFloat]);
end;
function TFloatToCurrencyNode.NodeType: TResultType;
begin
Result:=rtCurrency;
end;
procedure TFloatToCurrencyNode.GetNodeValue(var Result: TFPExpressionResult);
begin
Operand.GetNodeValue(Result);
Result.ResultType:=rtCurrency;
Result.ResCurrency:=Result.ResFloat;
end;
{ TIntToCurrencyNode }
function TIntToCurrencyNode.NodeType: TResultType;
begin
Result:=rtCurrency;
end;
procedure TIntToCurrencyNode.GetNodeValue(var Result: TFPExpressionResult);
begin
Operand.GetNodeValue(Result);
Result.ResCurrency:=Result.ResInteger;
Result.ResultType:=rtCurrency;
end;
{ TFPModuloOperation }
procedure TFPModuloOperation.Check;
@ -936,47 +1019,16 @@ procedure TAggregateMax.InitAggregate;
begin
inherited InitAggregate;
FFirst:=True;
FResult.ResultType:=rtFloat;
FResult.resFloat:=0;
FResult.ResultType:=FArgumentNodes[0].NodeType;
Case FResult.ResultType of
rtFloat : FResult.resFloat:=0.0;
rtCurrency : FResult.resCurrency:=0.0;
rtInteger : FResult.resInteger:=0;
end;
end;
procedure TAggregateMax.UpdateAggregate;
Var
OK : Boolean;
N : TFPExpressionResult;
begin
FArgumentNodes[0].GetNodeValue(N);
if FFirst then
begin
FFirst:=False;
OK:=True;
end
else
Case N.ResultType of
rtFloat: OK:=N.ResFloat>FResult.ResFloat;
rtinteger: OK:=N.ResInteger>FResult.ResFloat;
end;
if OK then
Case N.ResultType of
rtFloat: FResult.ResFloat:=N.ResFloat;
rtinteger: FResult.ResFloat:=N.ResInteger;
end;
end;
{ TAggregateMin }
procedure TAggregateMin.InitAggregate;
begin
inherited InitAggregate;
FFirst:=True;
FResult.ResultType:=rtFloat;
FResult.resFloat:=0;
end;
procedure TAggregateMin.UpdateAggregate;
Var
OK : Boolean;
N : TFPExpressionResult;
@ -989,14 +1041,57 @@ begin
FFirst:=False;
OK:=True;
end
else
Case N.ResultType of
rtFloat: OK:=N.ResFloat>FResult.ResFloat;
rtCurrency: OK:=N.ResCurrency>FResult.ResCurrency;
rtinteger: OK:=N.ResInteger>FResult.ResFloat;
end;
if OK then
Case N.ResultType of
rtFloat: FResult.ResFloat:=N.ResFloat;
rtinteger: FResult.ResFloat:=N.ResInteger;
rtCurrency: FResult.ResCurrency:=N.ResCurrency;
end;
end;
{ TAggregateMin }
procedure TAggregateMin.InitAggregate;
begin
inherited InitAggregate;
FFirst:=True;
FResult.ResultType:=FArgumentNodes[0].NodeType;
Case FResult.ResultType of
rtFloat : FResult.resFloat:=0.0;
rtCurrency : FResult.resCurrency:=0.0;
rtInteger : FResult.resInteger:=0;
end;
end;
procedure TAggregateMin.UpdateAggregate;
Var
OK : Boolean;
N : TFPExpressionResult;
begin
FArgumentNodes[0].GetNodeValue(N);
if FFirst then
begin
FFirst:=False;
OK:=True;
end
else
Case N.ResultType of
rtFloat: OK:=N.ResFloat<FResult.ResFloat;
rtCurrency: OK:=N.ResCurrency<FResult.ResCurrency;
rtinteger: OK:=N.ResInteger<FResult.ResFloat;
end;
if OK then
Case FResult.ResultType of
rtFloat: FResult.ResFloat:=N.ResFloat;
rtCurrency: FResult.ResCurrency:=N.ResCurrency;
rtinteger: FResult.ResFloat:=N.ResInteger;
end;
inherited UpdateAggregate;
@ -1007,7 +1102,6 @@ end;
procedure TAggregateAvg.InitAggregate;
begin
inherited InitAggregate;
FCount:=0;
end;
procedure TAggregateAvg.UpdateAggregate;
@ -1019,15 +1113,30 @@ end;
procedure TAggregateAvg.GetNodeValue(var Result: TFPExpressionResult);
begin
inherited GetNodeValue(Result);
Result.ResultType:=rtFloat;
Result.ResultType:=FResult.ResultType;
if FCount=0 then
Result.ResFloat:=0
Case FResult.ResultType of
rtInteger:
begin
Result.ResultType:=rtFloat;
Result.ResFloat:=0.0;
end;
rtFloat:
Result.ResFloat:=0.0;
rtCurrency:
Result.ResCurrency:=0.0;
end
else
Case FResult.ResultType of
rtInteger:
begin
Result.ResultType:=rtFloat;
Result.ResFloat:=FResult.ResInteger/FCount;
end;
rtFloat:
Result.ResFloat:=FResult.ResFloat/FCount;
rtCurrency:
Result.ResCurrency:=FResult.ResCurrency/FCount;
end;
end;
@ -1058,12 +1167,20 @@ end;
{ TAggregateSum }
function TAggregateSum.ConvertArgument(aIndex: Integer; aNode: TFPExprNode; aType: TResultType): TFPExprNode;
begin
if not (aNode.NodeType in [rtFloat,rtInteger,rtCurrency]) then
RaiseParserError(SErrInvalidArgumentType,[aIndex,ResultTypeName(aType),ResultTypeName(aNode.NodeType)]);
Result:=aNode;
end;
procedure TAggregateSum.InitAggregate;
begin
FResult.ResultType:=FArgumentNodes[0].NodeType;
Case FResult.ResultType of
rtFloat: FResult.ResFloat:=0.0;
rtCurrency : FResult.ResCurrency:=0.0;
rtinteger: FResult.ResInteger:=0;
end;
end;
@ -1077,6 +1194,7 @@ begin
FArgumentNodes[0].GetNodeValue(R);
Case FResult.ResultType of
rtFloat: FResult.ResFloat:=FResult.ResFloat+R.ResFloat;
rtCurrency: FResult.ResCurrency:=FResult.ResCurrency+R.ResCurrency;
rtinteger: FResult.ResInteger:=FResult.ResInteger+R.ResInteger;
end;
end;
@ -1468,7 +1586,7 @@ begin
FIdentifiers.Assign(AValue)
end;
procedure TFPExpressionParser.EvaluateExpression(var Result: TFPExpressionResult);
procedure TFPExpressionParser.EvaluateExpression(Out Result: TFPExpressionResult);
begin
If (FExpression='') then
ParserError(SErrInExpressionEmpty);
@ -1493,19 +1611,26 @@ begin
Raise EExprParser.Create(Msg);
end;
function TFPExpressionParser.ConvertNode(Todo : TFPExprNode; ToType : TResultType): TFPExprNode;
Class function TFPExpressionParser.ConvertNode(Todo : TFPExprNode; ToType : TResultType): TFPExprNode;
begin
Result:=ToDo;
Case ToDo.NodeType of
rtInteger :
Case ToType of
rtFloat : Result:=TIntToFloatNode.Create(Result);
rtCurrency : Result:=TIntToCurrencyNode.Create(Result);
rtDateTime : Result:=TIntToDateTimeNode.Create(Result);
end;
rtFloat :
Case ToType of
rtCurrency : Result:=TFloatToCurrencyNode.Create(Result);
rtDateTime : Result:=TFloatToDateTimeNode.Create(Result);
end;
rtCurrency :
Case ToType of
rtFloat : Result:=TCurrencyToFloatNode.Create(Result);
rtDateTime : Result:=TCurrencyToDateTimeNode.Create(Result);
end;
end;
end;
@ -1537,8 +1662,26 @@ var
begin
EvaluateExpression(Res);
CheckResultType(Res,rtFloat);
Result:=Res.ResFloat;
CheckResultTypes(Res,[rtFloat,rtCurrency,rtInteger]);
case Res.ResultType of
rtInteger : Result:=Res.ResInteger;
rtFloat : Result:=Res.ResFloat;
rtCurrency : Result:=res.ResCurrency;
end;
end;
function TFPExpressionParser.GetAsCurrency: Currency;
var
Res: TFPExpressionResult;
begin
EvaluateExpression(Res);
CheckResultTypes(Res,[rtFloat,rtCurrency,rtInteger]);
case Res.ResultType of
rtInteger : Result:=Res.ResInteger;
rtFloat : Result:=Res.ResFloat;
rtCurrency : Result:=res.ResCurrency;
end;
end;
function TFPExpressionParser.GetAsInteger: Int64;
@ -1572,24 +1715,23 @@ end;
function TFPExpressionParser.MatchNodes(Todo,Match : TFPExprNode): TFPExprNode;
Var
TT,MT : TResultType;
FromType,ToType : TResultType;
begin
Result:=Todo;
TT:=Todo.NodeType;
MT:=Match.NodeType;
If (TT<>MT) then
begin
if (TT=rtInteger) then
begin
if (MT in [rtFloat,rtDateTime]) then
Result:=ConvertNode(Todo,MT);
end
else if (TT=rtFloat) then
begin
if (MT=rtDateTime) then
Result:=ConvertNode(Todo,rtDateTime);
end;
FromType:=Todo.NodeType;
ToType:=Match.NodeType;
If (FromType<>ToType) then
Case FromType of
rtInteger:
if (ToType in [rtFloat,rtCurrency,rtDateTime]) then
Result:=ConvertNode(Todo,toType);
rtFloat:
if (ToType in [rtCurrency,rtDateTime]) then
Result:=ConvertNode(Todo,toType);
rtCurrency:
if (ToType in [rtFloat,rtDateTime]) then
Result:=ConvertNode(Todo,toType);
end;
end;
@ -1937,6 +2079,12 @@ begin
RaiseParserError(SErrInvalidResultType,[ResultTypeName(Res.ResultType)]);
end;
procedure TFPExpressionParser.CheckResultTypes(const Res: TFPExpressionResult; ATypes: TResultTypes);
begin
If Not (Res.ResultType in ATypes) then
RaiseParserError(SErrInvalidResultType,[ResultTypeName(Res.ResultType)]);
end;
class function TFPExpressionParser.BuiltinsManager: TExprBuiltInManager;
begin
Result:=BuiltinIdentifiers;
@ -2085,6 +2233,15 @@ begin
Result.FValue.ResFloat:=AValue;
end;
function TFPExprIdentifierDefs.AddCurrencyVariable(const AName: ShortString; AValue: Currency): TFPExprIdentifierDef;
begin
Result:=Add as TFPExprIdentifierDef;
Result.IdentifierType:=itVariable;
Result.Name:=AName;
Result.ResultType:=rtCurrency;
Result.FValue.ResCurrency:=AValue;
end;
function TFPExprIdentifierDefs.AddStringVariable(const AName: ShortString;
AValue: String): TFPExprIdentifierDef;
begin
@ -2172,6 +2329,7 @@ begin
rtBoolean : FValue.ResBoolean:=FStringValue='True';
rtInteger : FValue.ResInteger:=StrToInt(AValue);
rtFloat : FValue.ResFloat:=StrToFloat(AValue, FileFormatSettings);
rtCurrency : FValue.ResFloat:=StrToCurr(AValue, FileFormatSettings);
rtDateTime : FValue.ResDateTime:=StrToDateTime(AValue, FileFormatSettings);
rtString : FValue.ResString:=AValue;
end
@ -2180,6 +2338,7 @@ begin
rtBoolean : FValue.ResBoolean:=False;
rtInteger : FValue.ResInteger:=0;
rtFloat : FValue.ResFloat:=0.0;
rtCurrency : FValue.ResCurrency:=0.0;
rtDateTime : FValue.ResDateTime:=0;
rtString : FValue.ResString:='';
end
@ -2260,6 +2419,13 @@ begin
FValue.ResFloat:=AValue;
end;
procedure TFPExprIdentifierDef.SetAsCurrency(const AValue: Currency);
begin
CheckVariable;
CheckResultType(rtCurrency);
FValue.ResCurrency:=AValue;
end;
procedure TFPExprIdentifierDef.SetAsInteger(const AValue: Int64);
begin
CheckVariable;
@ -2283,6 +2449,7 @@ begin
Result:='False';
rtInteger : Result:=IntToStr(FValue.ResInteger);
rtFloat : Result:=FloatToStr(FValue.ResFloat, FileFormatSettings);
rtCurrency : Result:=CurrToStr(FValue.ResCurrency, FileFormatSettings);
rtDateTime : Result:=FormatDateTime('cccc',FValue.ResDateTime, FileFormatSettings);
rtString : Result:=FValue.ResString;
end;
@ -2304,7 +2471,7 @@ begin
if RT2<>RT then
begin
// Automatically convert integer to float.
if (rt2=rtInteger) and (rt=rtFLoat) then
if (rt2=rtInteger) and (rt=rtFloat) then
begin
FValue.ResultType:=RT;
I:=FValue.resInteger;
@ -2340,6 +2507,13 @@ begin
Result:=FValue.ResFloat;
end;
function TFPExprIdentifierDef.GetAsCurrency: Currency;
begin
CheckResultType(rtCurrency);
CheckVariable;
Result:=FValue.ResCurrency;
end;
function TFPExprIdentifierDef.GetAsBoolean: Boolean;
begin
CheckResultType(rtBoolean);
@ -2445,6 +2619,13 @@ begin
Result.Category:=ACategory;
end;
function TExprBuiltInManager.AddCurrencyVariable(const ACategory: TBuiltInCategory; const AName: ShortString; AValue: Currency
): TFPBuiltInExprIdentifierDef;
begin
Result:=TFPBuiltInExprIdentifierDef(FDefs.AddCurrencyVariable(AName,AValue));
Result.Category:=ACategory;
end;
function TExprBuiltInManager.AddStringVariable(
const ACategory: TBuiltInCategory; const AName: ShortString; AValue: String
): TFPBuiltInExprIdentifierDef;
@ -2621,6 +2802,13 @@ begin
FValue.ResFloat:=AValue;
end;
constructor TFPConstExpression.CreateCurrency(AValue: Currency);
begin
Inherited create;
FValue.ResultType:=rtCurrency;
FValue.ResCurrency:=AValue;
end;
constructor TFPConstExpression.CreateBoolean(AValue: Boolean);
begin
FValue.ResultType:=rtBoolean;
@ -2650,6 +2838,7 @@ begin
rtDateTime : Result:=''''+FormatDateTime('cccc',FValue.resDateTime)+'''';
rtBoolean : If FValue.ResBoolean then Result:='True' else Result:='False';
rtFloat : Str(FValue.ResFloat,Result);
rtCurrency : Str(FValue.ResCurrency,Result);
end;
end;
@ -2659,7 +2848,7 @@ end;
procedure TFPNegateOperation.Check;
begin
Inherited;
If Not (Operand.NodeType in [rtInteger,rtFloat]) then
If Not (Operand.NodeType in [rtInteger,rtFloat,rtCurrency]) then
RaiseParserError(SErrNoNegation,[ResultTypeName(Operand.NodeType),Operand.AsString])
end;
@ -2674,6 +2863,7 @@ begin
Case Result.ResultType of
rtInteger : Result.resInteger:=-Result.ResInteger;
rtFloat : Result.resFloat:=-Result.ResFloat;
rtCurrency : Result.resCurrency:=-Result.ResCurrency;
end;
end;
@ -2917,7 +3107,8 @@ begin
Case RT.ResultType of
rtBoolean : B:=RT.ResBoolean=RV.ResBoolean;
rtInteger : B:=RT.ResInteger=RV.ResInteger;
rtFloat : B:=RT.ResFloat=RV.ResFLoat;
rtFloat : B:=RT.ResFloat=RV.ResFloat;
rtCurrency : B:=RT.resCurrency=RV.resCurrency;
rtDateTime : B:=RT.ResDateTime=RV.ResDateTime;
rtString : B:=RT.ResString=RV.ResString;
end;
@ -3072,7 +3263,8 @@ begin
Case Result.ResultType of
rtBoolean : Result.resBoolean:=Result.ResBoolean=RRes.ResBoolean;
rtInteger : Result.resBoolean:=Result.ResInteger=RRes.ResInteger;
rtFloat : Result.resBoolean:=Result.ResFloat=RRes.ResFLoat;
rtFloat : Result.resBoolean:=Result.ResFloat=RRes.ResFloat;
rtCurrency : Result.resBoolean:=Result.resCurrency=RRes.resCurrency;
rtDateTime : Result.resBoolean:=Result.ResDateTime=RRes.ResDateTime;
rtString : Result.resBoolean:=Result.ResString=RRes.ResString;
end;
@ -3109,7 +3301,8 @@ begin
Right.GetNodeValue(RRes);
Case Result.ResultType of
rtInteger : Result.resBoolean:=Result.ResInteger<RRes.ResInteger;
rtFloat : Result.resBoolean:=Result.ResFloat<RRes.ResFLoat;
rtFloat : Result.resBoolean:=Result.ResFloat<RRes.ResFloat;
rtCurrency : Result.resBoolean:=Result.resCurrency<RRes.resCurrency;
rtDateTime : Result.resBoolean:=Result.ResDateTime<RRes.ResDateTime;
rtString : Result.resBoolean:=Result.ResString<RRes.ResString;
end;
@ -3135,10 +3328,17 @@ begin
rtInteger : case Right.NodeType of
rtInteger : Result.resBoolean:=Result.ResInteger>RRes.ResInteger;
rtFloat : Result.resBoolean:=Result.ResInteger>RRes.ResFloat;
rtCurrency : Result.resBoolean:=Result.ResInteger>RRes.resCurrency;
end;
rtFloat : case Right.NodeType of
rtInteger : Result.resBoolean:=Result.ResFloat>RRes.ResInteger;
rtFloat : Result.resBoolean:=Result.ResFloat>RRes.ResFLoat;
rtFloat : Result.resBoolean:=Result.ResFloat>RRes.ResFloat;
rtCurrency : Result.resBoolean:=Result.ResFloat>RRes.ResCurrency;
end;
rtCurrency : case Right.NodeType of
rtInteger : Result.resBoolean:=Result.ResCurrency>RRes.ResInteger;
rtFloat : Result.resBoolean:=Result.ResCurrency>RRes.ResFloat;
rtCurrency : Result.resBoolean:=Result.ResCurrency>RRes.ResCurrency;
end;
rtDateTime : Result.resBoolean:=Result.ResDateTime>RRes.ResDateTime;
rtString : Result.resBoolean:=Result.ResString>RRes.ResString;
@ -3177,7 +3377,7 @@ end;
procedure TFPOrderingOperation.Check;
Const
AllowedTypes =[rtInteger,rtfloat,rtDateTime,rtString];
AllowedTypes =[rtInteger,rtfloat,rtCurrency,rtDateTime,rtString];
begin
CheckNodeType(Left,AllowedTypes);
@ -3190,7 +3390,7 @@ end;
procedure TMathOperation.Check;
Const
AllowedTypes =[rtInteger,rtfloat,rtDateTime,rtString];
AllowedTypes =[rtInteger,rtfloat,rtCurrency,rtDateTime,rtString];
begin
inherited Check;
@ -3223,7 +3423,8 @@ begin
rtInteger : Result.ResInteger:=Result.ResInteger+RRes.ResInteger;
rtString : Result.ResString:=Result.ResString+RRes.ResString;
rtDateTime : Result.ResDateTime:=Result.ResDateTime+RRes.ResDateTime;
rtFloat : Result.ResFLoat:=Result.ResFLoat+RRes.ResFLoat;
rtFloat : Result.ResFloat:=Result.ResFloat+RRes.ResFloat;
rtCurrency : Result.ResCurrency:=Result.ResCurrency+RRes.ResCurrency;
end;
Result.ResultType:=NodeType;
end;
@ -3233,7 +3434,7 @@ end;
procedure TFPSubtractOperation.check;
Const
AllowedTypes =[rtInteger,rtfloat,rtDateTime];
AllowedTypes =[rtInteger,rtfloat,rtCurrency,rtDateTime];
begin
CheckNodeType(Left,AllowedTypes);
@ -3257,7 +3458,8 @@ begin
case Result.ResultType of
rtInteger : Result.ResInteger:=Result.ResInteger-RRes.ResInteger;
rtDateTime : Result.ResDateTime:=Result.ResDateTime-RRes.ResDateTime;
rtFloat : Result.ResFLoat:=Result.ResFLoat-RRes.ResFLoat;
rtFloat : Result.ResFloat:=Result.ResFloat-RRes.ResFloat;
rtCurrency : Result.resCurrency:=Result.resCurrency-RRes.ResCurrency;
end;
end;
@ -3266,7 +3468,7 @@ end;
procedure TFPMultiplyOperation.check;
Const
AllowedTypes =[rtInteger,rtfloat];
AllowedTypes =[rtInteger,rtCurrency,rtfloat];
begin
CheckNodeType(Left,AllowedTypes);
@ -3288,7 +3490,8 @@ begin
Right.GetNodeValue(RRes);
case Result.ResultType of
rtInteger : Result.ResInteger:=Result.ResInteger*RRes.ResInteger;
rtFloat : Result.ResFLoat:=Result.ResFLoat*RRes.ResFLoat;
rtFloat : Result.ResFloat:=Result.ResFloat*RRes.ResFloat;
rtCurrency : Result.ResCurrency:=Result.ResCurrency*RRes.ResCurrency;
end;
end;
@ -3296,7 +3499,7 @@ end;
procedure TFPDivideOperation.check;
Const
AllowedTypes =[rtInteger,rtfloat];
AllowedTypes =[rtInteger,rtCurrency,rtfloat];
begin
CheckNodeType(Left,AllowedTypes);
@ -3310,8 +3513,12 @@ begin
end;
function TFPDivideOperation.NodeType: TResultType;
begin
Result:=rtFLoat;
if (Left.NodeType=rtCurrency) and (Right.NodeType=rtCurrency) then
Result:=rtCurrency
else
Result:=rtFloat;
end;
Procedure TFPDivideOperation.GetNodeValue(var Result : TFPExpressionResult);
@ -3324,16 +3531,21 @@ begin
Right.GetNodeValue(RRes);
case Result.ResultType of
rtInteger : Result.ResFloat:=Result.ResInteger/RRes.ResInteger;
rtFloat : Result.ResFLoat:=Result.ResFLoat/RRes.ResFLoat;
rtFloat : Result.ResFloat:=Result.ResFloat/RRes.ResFloat;
rtCurrency :
if NodeType=rtCurrency then
Result.ResCurrency:=Result.ResCurrency/RRes.ResCurrency
else
Result.ResFloat:=Result.ResFloat/RRes.ResFloat;
end;
Result.ResultType:=rtFloat;
Result.ResultType:=NodeType;
end;
{ TFPPowerOperation }
procedure TFPPowerOperation.Check;
const
AllowedTypes = [rtInteger, rtFloat];
AllowedTypes = [rtInteger, rtCurrency, rtFloat];
begin
CheckNodeType(Left, AllowedTypes);
CheckNodeType(Right, AllowedTypes);
@ -3440,6 +3652,46 @@ begin
Result.ResultType:=rtDateTime;
end;
{ TCurrencyToDateTimeNode }
procedure TCurrencyToDateTimeNode.Check;
begin
inherited Check;
CheckNodeType(Operand,[rtCurrency]);
end;
function TCurrencyToDateTimeNode.NodeType: TResultType;
begin
Result:=rtDateTime;
end;
Procedure TCurrencyToDateTimeNode.GetNodeValue(var Result : TFPExpressionResult);
begin
Operand.GetNodeValue(Result);
Result.ResDateTime:=Result.ResCurrency;
Result.ResultType:=rtDateTime;
end;
{ TCurrencyToFloatNode }
procedure TCurrencyToFloatNode.Check;
begin
inherited Check;
CheckNodeType(Operand,[rtCurrency]);
end;
function TCurrencyToFloatNode.NodeType: TResultType;
begin
Result:=rtFloat;
end;
Procedure TCurrencyToFloatNode.GetNodeValue(var Result : TFPExpressionResult);
begin
Operand.GetNodeValue(Result);
Result.ResFloat:=Result.ResCurrency;
Result.ResultType:=rtFloat;
end;
{ TFPExprIdentifierNode }
constructor TFPExprIdentifierNode.CreateIdentifier(AID: TFPExprIdentifierDef);
@ -3489,6 +3741,20 @@ begin
end;
end;
Function TFPExprFunction.ConvertArgument(aIndex : Integer; aNode : TFPExprNode; aType : TResultType) : TFPExprNode;
Var
N : TFPExprNode;
begin
// Automatically convert integers to floats for float/currency parameters
N:=TFPExpressionParser.ConvertNode(aNode,aType);
if (aNode=N) then
// No conversion was performed, raise error
RaiseParserError(SErrInvalidArgumentType,[aIndex,ResultTypeName(aType),ResultTypeName(aNode.NodeType)]);
Result:=N;
end;
function TFPExprFunction.HasAggregate: Boolean;
var
I: Integer;
@ -3515,22 +3781,13 @@ begin
begin
rtp:=CharToResultType(FID.ParameterTypes[i+1]);
rta:=FArgumentNodes[i].NodeType;
If (rtp<>rta) then begin
// Automatically convert integers to floats in functions that return
// a float
if (rta = rtInteger) and (rtp = rtFloat) then begin
FArgumentNodes[i] := TIntToFloatNode.Create(FArgumentNodes[i]);
exit;
end;
RaiseParserError(SErrInvalidArgumentType,[I+1,ResultTypeName(rtp),ResultTypeName(rta)])
end;
If (rtp<>rta) then
FArgumentNodes[i]:=ConvertArgument(I+1,FArgumentNodes[i],rtp);
end;
end;
constructor TFPExprFunction.CreateFunction(AID: TFPExprIdentifierDef;
const Args: TExprArgumentArray);
constructor TFPExprFunction.CreateFunction(AID: TFPExprIdentifierDef; const Args: TExprArgumentArray);
begin
Inherited CreateIdentifier(AID);
FArgumentNodes:=Args;
@ -3637,6 +3894,8 @@ function ArgToFloat(Arg: TFPExpressionResult): TExprFloat;
begin
if Arg.ResultType = rtInteger then
result := Arg.resInteger
else if Arg.ResultType = rtCurrency then
result := Arg.resCurrency
else
result := Arg.resFloat;
end;

275
packages/fcl-base/tests/testexprpars.pp
View File

@ -506,6 +506,7 @@ type
procedure DoEchoBoolean(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoEchoDate(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoEchoFloat(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoEchoCurrency(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoEchoInteger(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoEchoString(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
procedure DoGetDate(var Result: TFPExpressionResult; Const Args: TExprParameterArray);
@ -518,6 +519,7 @@ type
Procedure AssertOperand(N : TFPExprNode; OperandClass : TClass);
Procedure AssertResultType(RT : TResultType);
Procedure AssertResult(F : TExprFloat);
Procedure AssertCurrencyResult(C : Currency);
Procedure AssertResult(I : Int64);
Procedure AssertResult(S : String);
Procedure AssertResult(B : Boolean);
@ -730,9 +732,10 @@ type
FTest33 : TFPExprIdentifierDef;
procedure DoGetBooleanVar(var Res: TFPExpressionResult; ConstRef AName: ShortString);
procedure DoGetBooleanVarWrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
procedure DoTestVariable33;
procedure TestAccess(Skip: TResultType);
procedure TestAccess(Skip: TResultTypes);
Protected
procedure DoTestVariable33;
procedure AddVariabletwice;
procedure UnknownVariable;
Procedure ReadWrongType;
@ -775,6 +778,8 @@ type
procedure TestVariable32;
procedure TestVariable33;
procedure TestVariable34;
procedure TestVariable35;
procedure TestVariable36;
end;
{ TTestParserFunctions }
@ -814,6 +819,10 @@ type
procedure TestFunction27;
procedure TestFunction28;
procedure TestFunction29;
procedure TestFunction30;
procedure TestFunction31;
procedure TestFunction32;
procedure TestFunction33;
end;
{ TAggregateNode }
@ -851,6 +860,7 @@ type
Procedure TestCountAggregate;
Procedure TestSumAggregate;
Procedure TestSumAggregate2;
Procedure TestSumAggregate3;
Procedure TestAvgAggregate;
Procedure TestAvgAggregate2;
Procedure TestAvgAggregate3;
@ -871,6 +881,7 @@ type
procedure TestVariable4;
procedure TestVariable5;
procedure TestVariable6;
procedure TestVariable7;
procedure TestFunction1;
procedure TestFunction2;
end;
@ -895,6 +906,7 @@ type
procedure AssertDateTimeExpression(Const AExpression : String; Const AResult : TDateTime);
procedure AssertAggregateExpression(Const AExpression : String; AResult : Int64; AUpdateCount : integer);
procedure AssertAggregateExpression(Const AExpression : String; AResult : TExprFloat; AUpdateCount : integer);
procedure AssertAggregateCurrExpression(Const AExpression : String; AResult : Currency; AUpdateCount : integer);
Published
procedure TestRegister;
Procedure TestVariablepi;
@ -962,6 +974,8 @@ type
Procedure TestFunctionstrtodatetime;
Procedure TestFunctionstrtodatetimedef;
Procedure TestFunctionAggregateSum;
Procedure TestFunctionAggregateSumFloat;
Procedure TestFunctionAggregateSumCurrency;
Procedure TestFunctionAggregateCount;
Procedure TestFunctionAggregateAvg;
Procedure TestFunctionAggregateMin;
@ -1004,6 +1018,7 @@ begin
Case Result.ResultType of
rtInteger : Result.ResInteger:=FVarValue;
rtFloat : Result.ResFloat:=FVarValue / 2;
rtCurrency : Result.ResCurrency:=FVarValue / 2;
end;
end;
@ -1163,6 +1178,40 @@ begin
end;
end;
procedure TTestParserAggregate.TestSumAggregate3;
Var
C : TAggregateSum;
V : TFPExprVariable;
I : Integer;
R : TFPExpressionResult;
A : TExprArgumentArray;
begin
FFunction.ResultType:=rtCurrency;
FFunction.ParameterTypes:='F';
FFunction.Name:='SUM';
FFunction2.ResultType:=rtCurrency;
C:=Nil;
V:=TFPExprVariable.CreateIdentifier(FFunction2);
try
SetLength(A,1);
A[0]:=V;
C:=TAggregateSum.CreateFunction(FFunction,A);
C.Check;
C.InitAggregate;
For I:=1 to 10 do
begin
FVarValue:=I;
C.UpdateAggregate;
end;
C.GetNodeValue(R);
AssertEquals('Correct type',rtCurrency,R.ResultType);
AssertEquals('Correct value',55/2,R.ResCurrency,0.1);
finally
C.Free;
end;
end;
procedure TTestParserAggregate.TestAvgAggregate;
Var
@ -1237,7 +1286,6 @@ procedure TTestParserAggregate.TestAvgAggregate3;
Var
C : TAggregateAvg;
V : TFPExprVariable;
I : Integer;
R : TFPExpressionResult;
A : TExprArgumentArray;
@ -1565,6 +1613,7 @@ begin
AssertEquals('Correct result',2.34,FN.ConstValue.ResFloat);
AssertEquals('Correct result',2.34,FN.NodeValue.ResFloat);
Val(FN.AsString,F,C);
AssertEquals('Correct conversion',0,C);
AssertEquals('AsString ok',2.34,F,0.001);
end;
@ -2828,6 +2877,12 @@ begin
AssertEquals('Correct float result',F,FP.Evaluate.ResFloat);
end;
procedure TTestExpressionParser.AssertCurrencyResult(C: Currency);
begin
AssertEquals('Correct currency result',C,FP.ExprNode.NodeValue.ResCurrency);
AssertEquals('Correct currency result',C,FP.Evaluate.ResCurrency);
end;
procedure TTestExpressionParser.AssertResult(I: Int64);
begin
AssertEquals('Correct integer result',I,FP.ExprNode.NodeValue.ResInteger);
@ -4439,6 +4494,7 @@ begin
rtString : res.ResString:=FP.Identifiers[0].AsString;
rtInteger : Res.ResInteger:=FP.Identifiers[0].AsInteger;
rtFloat : Res.ResFloat:=FP.Identifiers[0].AsFloat;
rtCurrency : Res.ResCurrency:=FP.Identifiers[0].AsCurrency;
rtDateTime : Res.ResDateTime:=FP.Identifiers[0].AsDateTime;
end;
end;
@ -4455,6 +4511,7 @@ begin
rtString : FP.Identifiers[0].AsString:=res.ResString;
rtInteger : FP.Identifiers[0].AsInteger:=Res.ResInteger;
rtFloat : FP.Identifiers[0].AsFloat:=Res.ResFloat;
rtCurrency : FP.Identifiers[0].AsCurrency:=Res.ResCurrency;
rtDateTime : FP.Identifiers[0].AsDateTime:=Res.ResDateTime;
end;
end;
@ -4540,14 +4597,12 @@ Var
begin
D:=Now;
I:=FP.Identifiers.AddDateTimeVariable('a',D);
AssertNotNull('Addvariable returns result',I);
AssertException('Cannot add same name twice',EExprParser,@AddVariabletwice);
end;
procedure TTestParserVariables.TestVariable8;
Var
I : TFPExprIdentifierDef;
begin
FP.Identifiers.AddIntegerVariable('a',123);
FP.Identifiers.AddIntegerVariable('b',123);
@ -4564,6 +4619,7 @@ Var
begin
I:=FP.Identifiers.AddIntegerVariable('a',123);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
@ -4578,6 +4634,7 @@ Var
begin
I:=FP.Identifiers.AddStringVariable('a','a123');
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
@ -4592,6 +4649,7 @@ Var
begin
I:=FP.Identifiers.AddFloatVariable('a',1.23);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
@ -4599,6 +4657,21 @@ begin
AssertResult(1.23);
end;
procedure TTestParserVariables.TestVariable36;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddCurrencyVariable('a',1.23);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
AssertResultType(rtCurrency);
AssertCurrencyResult(1.23);
end;
procedure TTestParserVariables.TestVariable12;
Var
@ -4606,6 +4679,7 @@ Var
begin
I:=FP.Identifiers.AddBooleanVariable('a',True);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
@ -4622,6 +4696,7 @@ Var
begin
D:=Date;
I:=FP.Identifiers.AddDateTimeVariable('a',D);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='a';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPExprVariable, FP.ExprNode);
@ -4648,6 +4723,7 @@ Var
begin
I:=FP.Identifiers.AddIntegerVariable('a',1);
AssertNotNull('Addvariable returns result',I);
FP.BuildHashList;
S:=FP.IdentifierByName('A');
AssertSame('Identifier found',I,S);
@ -4660,6 +4736,7 @@ Var
begin
I:=FP.Identifiers.AddIntegerVariable('a',1);
AssertNotNull('Addvariable returns result',I);
FP.BuildHashList;
S:=FP.IdentifierByName('B');
AssertNull('Identifier not found',S);
@ -4668,10 +4745,11 @@ end;
procedure TTestParserVariables.TestVariable17;
Var
I,S : TFPExprIdentifierDef;
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddIntegerVariable('a',1);
AssertNotNull('Addvariable returns result',I);
FP.BuildHashList;
AssertException('Identifier not found',EExprParser,@unknownvariable);
end;
@ -4683,6 +4761,7 @@ Var
begin
I:=FP.Identifiers.AddIntegerVariable('a',1);
AssertNotNull('Addvariable returns result',I);
S:=FP.Identifiers.FindIdentifier('B');
AssertNull('Identifier not found',S);
end;
@ -4711,18 +4790,24 @@ end;
procedure TTestParserVariables.TestAccess(Skip : TResultType);
begin
TestAccess([Skip]);
end;
procedure TTestParserVariables.TestAccess(Skip : TResultTypes);
Var
rt : TResultType;
begin
For rt:=Low(TResultType) to High(TResultType) do
if rt<>skip then
if Not (rt in skip) then
begin
FasWrongType:=rt;
AssertException('Acces as '+ResultTypeName(rt),EExprParser,@ReadWrongtype);
end;
For rt:=Low(TResultType) to High(TResultType) do
if rt<>skip then
if Not (rt in skip) then
begin
FasWrongType:=rt;
AssertException('Acces as '+ResultTypeName(rt),EExprParser,@WriteWrongtype);
@ -4732,13 +4817,20 @@ end;
procedure TTestParserVariables.TestVariable21;
begin
FP.IDentifiers.AddIntegerVariable('a',1);
TestAccess(rtInteger);
TestAccess([rtInteger]);
end;
procedure TTestParserVariables.TestVariable22;
begin
FP.IDentifiers.AddFloatVariable('a',1.0);
TestAccess(rtFloat);
TestAccess([rtFloat]);
end;
procedure TTestParserVariables.TestVariable35;
begin
FP.IDentifiers.AddCurrencyVariable('a',1.0);
TestAccess([rtCurrency]);
end;
procedure TTestParserVariables.TestVariable23;
@ -4886,6 +4978,7 @@ Var
begin
B:=FTest33.AsBoolean;
AssertTrue(B in [true,False])
end;
procedure TTestParserVariables.TestVariable33;
@ -4947,6 +5040,12 @@ begin
Result.resFloat:=Args[0].resFloat;
end;
Procedure EchoCurrency(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
begin
Result.resCurrency:=Args[0].resCurrency;
end;
Procedure EchoString(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
begin
@ -4977,6 +5076,12 @@ begin
Result.resFloat:=Args[0].resFloat;
end;
Procedure TTestExpressionParser.DoEchoCurrency(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
begin
Result.resCurrency:=Args[0].resCurrency;
end;
Procedure TTestExpressionParser.DoEchoString(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
begin
@ -5011,6 +5116,7 @@ begin
rtString : res.ResString:=FP.Identifiers[0].AsString;
rtInteger : Res.ResInteger:=FP.Identifiers[0].AsInteger;
rtFloat : Res.ResFloat:=FP.Identifiers[0].AsFloat;
rtCurrency : Res.ResCurrency:=FP.Identifiers[0].AsCurrency;
rtDateTime : Res.ResDateTime:=FP.Identifiers[0].AsDateTime;
end;
end;
@ -5027,6 +5133,7 @@ begin
rtString : FP.Identifiers[0].AsString:=res.ResString;
rtInteger : FP.Identifiers[0].AsInteger:=Res.ResInteger;
rtFloat : FP.Identifiers[0].AsFloat:=Res.ResFloat;
rtCurrency : FP.Identifiers[0].AsCurrency:=Res.ResCurrency;
rtDateTime : FP.Identifiers[0].AsDateTime:=Res.ResDateTime;
end;
end;
@ -5119,6 +5226,24 @@ begin
AssertException('No write access',EExprParser,@TryWrite);
end;
procedure TTestParserFunctions.TestFunction30;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddFunction('EchoCurrency','C','C',@EchoCurrency);
AssertEquals('List is dirty',True,FP.Dirty);
AssertNotNull('Addvariable returns result',I);
AssertEquals('One variable added',1,FP.Identifiers.Count);
AssertSame('Result equals variable added',I,FP.Identifiers[0]);
AssertEquals('Function has correct resulttype',rtCurrency,I.ResultType);
AssertSame('Function has correct address',Pointer(@EchoCurrency),Pointer(I.OnGetFunctionValueCallBack));
FaccessAs:=rtCurrency;
AssertException('No read access',EExprParser,@TryRead);
AssertException('No write access',EExprParser,@TryWrite);
end;
procedure TTestParserFunctions.TestFunction6;
Var
@ -5197,6 +5322,21 @@ begin
// AssertSame('Function has correct address',Pointer(@EchoFloat),Pointer(I.OnGetFunctionValueCallBack));
end;
procedure TTestParserFunctions.TestFunction31;
Var
I : TFPExprIdentifierDef;
begin
I:=FP.Identifiers.AddFunction('EchoCurrency','C','C',@DoEchoCurrency);
AssertEquals('List is dirty',True,FP.Dirty);
AssertNotNull('Addvariable returns result',I);
AssertEquals('One variable added',1,FP.Identifiers.Count);
AssertSame('Result equals variable added',I,FP.Identifiers[0]);
AssertEquals('Function has correct resulttype',rtCurrency,I.ResultType);
// AssertSame('Function has correct address',Pointer(@EchoFloat),Pointer(I.OnGetFunctionValueCallBack));
end;
procedure TTestParserFunctions.TestFunction11;
Var
@ -5221,6 +5361,7 @@ Var
begin
D:=Date;
I:=FP.Identifiers.AddFunction('Date','D','',@GetDate);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='Date';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5237,7 +5378,9 @@ Var
begin
D:=Date;
I:=FP.Identifiers.AddDateTimeVariable('a',D);
AssertNotNull('Addvariable returns result',I);
I:=FP.Identifiers.AddFunction('EchoDate','D','D',@EchoDate);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='EchoDate(a)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5248,11 +5391,10 @@ end;
procedure TTestParserFunctions.TestFunction14;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoInteger','I','I',@EchoInteger);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='EchoInteger(13)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5263,11 +5405,10 @@ end;
procedure TTestParserFunctions.TestFunction15;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoBoolean','B','B',@EchoBoolean);
AssertNotNull('Addvariable returns result',I);
FP.Expression:='EchoBoolean(True)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5278,11 +5419,10 @@ end;
procedure TTestParserFunctions.TestFunction16;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoFloat','F','F',@EchoFloat);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoFloat(1.234)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5290,14 +5430,47 @@ begin
AssertResult(1.234);
end;
procedure TTestParserFunctions.TestFunction17;
procedure TTestParserFunctions.TestFunction32;
Var
I : TFPExprIdentifierDef;
begin
// Note there will be an implicit conversion float-> currency as the const will be a float
I:=FP.Identifiers.AddFunction('EchoCurrency','C','C',@EchoCurrency);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoCurrency(1.234)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
AssertResultType(rtCurrency);
AssertCurrencyResult(1.234);
end;
procedure TTestParserFunctions.TestFunction33;
Var
I : TFPExprIdentifierDef;
begin
// Note there will be no conversion
I:=FP.Identifiers.AddCurrencyVariable('a',1.234);
AssertNotNull('Have identifier',I);
I:=FP.Identifiers.AddFunction('EchoCurrency','C','C',@EchoCurrency);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoCurrency(a)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
AssertResultType(rtCurrency);
AssertCurrencyResult(1.234);
end;
procedure TTestParserFunctions.TestFunction17;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoString','S','S',@EchoString);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoString(''Aloha'')';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionCallBack, FP.ExprNode);
@ -5315,7 +5488,9 @@ Var
begin
D:=Date;
I:=FP.Identifiers.AddDateTimeVariable('a',D);
AssertNotNull('Have identifier',I);
I:=FP.Identifiers.AddFunction('EchoDate','D','D',@DoEchoDate);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoDate(a)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionEventHandler, FP.ExprNode);
@ -5326,11 +5501,10 @@ end;
procedure TTestParserFunctions.TestFunction19;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoInteger','I','I',@DoEchoInteger);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoInteger(13)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionEventHandler, FP.ExprNode);
@ -5341,11 +5515,10 @@ end;
procedure TTestParserFunctions.TestFunction20;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoBoolean','B','B',@DoEchoBoolean);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoBoolean(True)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionEventHandler, FP.ExprNode);
@ -5356,11 +5529,10 @@ end;
procedure TTestParserFunctions.TestFunction21;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoFloat','F','F',@DoEchoFloat);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoFloat(1.234)';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionEventHandler, FP.ExprNode);
@ -5371,11 +5543,10 @@ end;
procedure TTestParserFunctions.TestFunction22;
Var
I : TFPExprIdentifierDef;
D : TDateTime;
begin
D:=Date;
I:=FP.Identifiers.AddFunction('EchoString','S','S',@DoEchoString);
AssertNotNull('Have identifier',I);
FP.Expression:='EchoString(''Aloha'')';
AssertNotNull('Have result node',FP.ExprNode);
AssertNodeType('Constant expression',TFPFunctionEventHandler, FP.ExprNode);
@ -5392,6 +5563,7 @@ Var
begin
D:=Date;
I:=FP.Identifiers.AddFunction('Date','D','',@DoGetDate);
AssertNotNull('Have identifier',I);
AssertEquals('List is dirty',True,FP.Dirty);
AssertNotNull('Addvariable returns result',I);
AssertEquals('One variable added',1,FP.Identifiers.Count);
@ -5411,8 +5583,8 @@ Var
begin
I:=FP.Identifiers.AddFunction('AddInteger','I','II',@DoAddInteger);
AssertNotNull('Have identifier',I);
AssertEquals('List is dirty',True,FP.Dirty);
AssertNotNull('Addvariable returns result',I);
AssertEquals('One variable added',1,FP.Identifiers.Count);
AssertSame('Result equals variable added',I,FP.Identifiers[0]);
AssertEquals('Function has correct resulttype',rtInteger,I.ResultType);
@ -5431,7 +5603,7 @@ Var
begin
I:=FP.Identifiers.AddFunction('Delete','S','SII',@DoDeleteString);
AssertEquals('List is dirty',True,FP.Dirty);
AssertNotNull('Addvariable returns result',I);
AssertNotNull('Have identifier',I);
AssertEquals('One variable added',1,FP.Identifiers.Count);
AssertSame('Result equals variable added',I,FP.Identifiers[0]);
AssertEquals('Function has correct resulttype',rtString,I.ResultType);
@ -5507,6 +5679,7 @@ Var
begin
// Test type mismatch
I:=FP.Identifiers.AddFunction('AddInteger','I','II',@DoAddInteger);
AssertNotNull('Addvariable returns result',I);
TestParser('AddInteger(3 and 2,''s'')');
end;
@ -5589,6 +5762,21 @@ begin
AssertEquals('Variable has correct value',FloatToStr(1.23),I.Value);
end;
procedure TTestBuiltinsManager.TestVariable7;
Var
I : TFPBuiltinExprIdentifierDef;
begin
I:=FM.AddCurrencyVariable(bcUser,'a',1.23);
AssertNotNull('Addvariable returns result',I);
AssertEquals('One variable added',1,FM.IdentifierCount);
AssertSame('Result equals variable added',I,FM.Identifiers[0]);
AssertEquals('Variable has correct category',ord(bcUser),Ord(I.Category));
AssertEquals('Variable has correct resulttype',rtCurrency,I.ResultType);
AssertEquals('Variable has correct value',CurrToStr(1.23),I.Value);
end;
procedure TTestBuiltinsManager.TestVariable5;
Var
@ -5786,6 +5974,21 @@ begin
AssertResult(AResult);
end;
procedure TTestBuiltins.AssertAggregateCurrExpression(Const AExpression : String; AResult : Currency; AUpdateCount : integer);
begin
FP.BuiltIns:=AllBuiltIns;
SetExpression(AExpression);
AssertEquals('Has aggregate',True,FP.ExprNode.HasAggregate);
FP.InitAggregate;
While AUpdateCount>0 do
begin
FP.UpdateAggregate;
Dec(AUpdateCount);
end;
AssertCurrencyResult(AResult);
end;
procedure TTestBuiltins.TestRegister;
begin
@ -6314,9 +6517,21 @@ end;
procedure TTestBuiltins.TestFunctionAggregateSum;
begin
FP.Identifiers.AddIntegerVariable('S',2);
AssertAggregateExpression('sum(S)',10,5);
end;
procedure TTestBuiltins.TestFunctionAggregateSumFloat;
begin
FP.Identifiers.AddFloatVariable('S',2.0);
AssertAggregateExpression('sum(S)',10.0,5);
end;
procedure TTestBuiltins.TestFunctionAggregateSumCurrency;
begin
FP.Identifiers.AddCurrencyVariable('S',2.0);
AssertAggregateCurrExpression('sum(S)',Currency(10.0),5);
end;
procedure TTestBuiltins.TestFunctionAggregateCount;
begin
AssertAggregateExpression('count',5,5);
@ -6796,7 +7011,7 @@ end;
initialization
RegisterTests([TTestExpressionScanner, TTestDestroyNode,
RegisterTests('ExprPars',[TTestExpressionScanner, TTestDestroyNode,
TTestConstExprNode,TTestNegateExprNode,
TTestBinaryAndNode,TTestBinaryOrNode,TTestBinaryXOrNode,
TTestNotNode,TTestEqualNode,TTestUnEqualNode,