diff --git a/packages/fcl-base/src/fpexprpars.pp b/packages/fcl-base/src/fpexprpars.pp index 1df8a6b4af..ff7054fe87 100644 --- a/packages/fcl-base/src/fpexprpars.pp +++ b/packages/fcl-base/src/fpexprpars.pp @@ -44,6 +44,8 @@ Type TFPExpressionParser = Class; TExprBuiltInManager = Class; + TFPExprFunction = Class; + TFPExprFunctionClass = Class of TFPExprFunction; { TFPExpressionScanner } @@ -106,6 +108,10 @@ Type Procedure GetNodeValue(var Result : TFPExpressionResult); virtual; abstract; Public Procedure Check; virtual; abstract; + Procedure InitAggregate; virtual; + Procedure UpdateAggregate; virtual; + Class Function IsAggregate : Boolean; virtual; + Function HasAggregate : Boolean; virtual; Function NodeType : TResultType; virtual; abstract; Function NodeValue : TFPExpressionResult; Function AsString : string; virtual; abstract; @@ -123,6 +129,9 @@ Type Public Constructor Create(ALeft,ARight : TFPExprNode); Destructor Destroy; override; + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + Function HasAggregate : Boolean; override; Procedure Check; override; Property left : TFPExprNode Read FLeft; Property Right : TFPExprNode Read FRight; @@ -245,6 +254,9 @@ Type Procedure GetNodeValue(var Result : TFPExpressionResult); override; Public Procedure Check; override; + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + Function HasAggregate : Boolean; override; Function NodeType : TResultType; override; Constructor Create(ACondition,ALeft,ARight : TFPExprNode); Destructor destroy; override; @@ -262,6 +274,9 @@ Type Procedure GetNodeValue(var Result : TFPExpressionResult); override; Public Procedure Check; override; + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + function HasAggregate: Boolean; override; Function NodeType : TResultType; override; Constructor Create(Args : TExprArgumentArray); Destructor destroy; override; @@ -322,6 +337,9 @@ Type Public Constructor Create(AOperand : TFPExprNode); Destructor Destroy; override; + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + Function HasAggregate : Boolean; override; Procedure Check; override; Property Operand : TFPExprNode Read FOperand; end; @@ -401,7 +419,7 @@ Type end; - TIdentifierType = (itVariable,itFunctionCallBack,itFunctionHandler); + TIdentifierType = (itVariable,itFunctionCallBack,itFunctionHandler,itFunctionNode); TFPExprFunctionCallBack = Procedure (Var Result : TFPExpressionResult; Const Args : TExprParameterArray); TFPExprFunctionEvent = Procedure (Var Result : TFPExpressionResult; Const Args : TExprParameterArray) of object; TFPExprVariableCallBack = Procedure (Var Result : TFPExpressionResult; ConstRef AName : ShortString); @@ -411,6 +429,7 @@ Type TFPExprIdentifierDef = Class(TCollectionItem) private + FNodeType: TFPExprFunctionClass; FOnGetVarValue: TFPExprVariableEvent; FOnGetVarValueCB: TFPExprVariableCallBack; FStringValue : String; @@ -459,10 +478,11 @@ Type Property ResultType : TResultType Read GetResultType Write SetResultType; Property OnGetFunctionValue : TFPExprFunctionEvent Read FOnGetValue Write FOnGetValue; Property OnGetVariableValue : TFPExprVariableEvent Read FOnGetVarValue Write FOnGetVarValue; + Property NodeType : TFPExprFunctionClass Read FNodeType Write FNodeType; end; - TBuiltInCategory = (bcStrings,bcDateTime,bcMath,bcBoolean,bcConversion,bcData,bcVaria,bcUser); + TBuiltInCategory = (bcStrings,bcDateTime,bcMath,bcBoolean,bcConversion,bcData,bcVaria,bcUser,bcAggregate); TBuiltInCategories = Set of TBuiltInCategory; { TFPBuiltInExprIdentifierDef } @@ -500,6 +520,7 @@ Type Function AddDateTimeVariable(Const AName : ShortString; AValue : TDateTime) : TFPExprIdentifierDef; Function AddFunction(Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ACallBack : TFPExprFunctionCallBack) : TFPExprIdentifierDef; Function AddFunction(Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ACallBack : TFPExprFunctionEvent) : TFPExprIdentifierDef; + Function AddFunction(Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ANodeClass : TFPExprFunctionClass) : TFPExprIdentifierDef; property Identifiers[AIndex : Integer] : TFPExprIdentifierDef Read GetI Write SetI; Default; end; @@ -541,6 +562,42 @@ Type Function AsString : String; override; end; + { TAggregateExpr } + + TAggregateExpr = Class(TFPExprFunction) + Protected + FResult : TFPExpressionResult; + Class Function IsAggregate : Boolean; override; + Procedure GetNodeValue(var Result : TFPExpressionResult); override; + end; + + { TAggregateSum } + + TAggregateSum = Class(TAggregateExpr) + Public + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + end; + + { TAggregateAvg } + + TAggregateAvg = Class(TAggregateSum) + Protected + FCount : Integer; + Public + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + Procedure GetNodeValue(var Result : TFPExpressionResult); override; + end; + + { TAggregateCount } + + TAggregateCount = Class(TAggregateExpr) + Public + Procedure InitAggregate; override; + Procedure UpdateAggregate; override; + end; + { TFPFunctionCallBack } TFPFunctionCallBack = Class(TFPExprFunction) @@ -610,8 +667,12 @@ Type Function IdentifierByName(const AName : ShortString) : TFPExprIdentifierDef; virtual; Procedure Clear; Procedure EvaluateExpression(Var Result : TFPExpressionResult); + function ExtractNode(var N: TFPExprNode): Boolean; Function Evaluate : TFPExpressionResult; Function ResultType : TResultType; + Function HasAggregate : Boolean; + Procedure InitAggregate; + Procedure UpdateAggregate; Property AsFloat : TExprFloat Read GetAsFloat; Property AsInteger : Int64 Read GetAsInteger; Property AsString : String Read GetAsString; @@ -647,22 +708,23 @@ Type 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; Function AddFunction(Const ACategory : TBuiltInCategory; Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ACallBack : TFPExprFunctionEvent) : TFPBuiltInExprIdentifierDef; + Function AddFunction(Const ACategory : TBuiltInCategory; Const AName : ShortString; Const AResultType : Char; Const AParamTypes : String; ANodeClass : TFPExprFunctionClass) : TFPBuiltInExprIdentifierDef; Property IdentifierCount : Integer Read GetCount; Property Identifiers[AIndex : Integer] :TFPBuiltInExprIdentifierDef Read GetI; end; EExprParser = Class(Exception); +Const + AllBuiltIns = [bcStrings,bcDateTime,bcMath,bcBoolean,bcConversion,bcData,bcVaria,bcUser,bcAggregate]; Function TokenName (AToken : TTokenType) : String; Function ResultTypeName (AResult : TResultType) : String; Function CharToResultType(C : Char) : TResultType; Function BuiltinIdentifiers : TExprBuiltInManager; -Procedure RegisterStdBuiltins(AManager : TExprBuiltInManager); +Procedure RegisterStdBuiltins(AManager : TExprBuiltInManager; Categories : TBuiltInCategories = AllBuiltIns); function ArgToFloat(Arg: TFPExpressionResult): TExprFloat; -Const - AllBuiltIns = [bcStrings,bcDateTime,bcMath,bcBoolean,bcConversion,bcData,bcVaria,bcUser]; implementation @@ -737,13 +799,13 @@ begin Raise EExprParser.CreateFmt(Fmt,Args); end; -Function TokenName (AToken : TTokenType) : String; +function TokenName(AToken: TTokenType): String; begin Result:=GetEnumName(TypeInfo(TTokenType),Ord(AToken)); end; -Function ResultTypeName (AResult : TResultType) : String; +function ResultTypeName(AResult: TResultType): String; begin Result:=GetEnumName(TypeInfo(TResultType),Ord(AResult)); @@ -765,7 +827,7 @@ end; Var BuiltIns : TExprBuiltInManager; -Function BuiltinIdentifiers : TExprBuiltInManager; +function BuiltinIdentifiers: TExprBuiltInManager; begin If (BuiltIns=Nil) then @@ -779,6 +841,85 @@ begin FreeAndNil(Builtins); end; +{ TAggregateAvg } + +procedure TAggregateAvg.InitAggregate; +begin + inherited InitAggregate; + FCount:=0; +end; + +procedure TAggregateAvg.UpdateAggregate; +begin + inherited UpdateAggregate; + Inc(FCount); +end; + +procedure TAggregateAvg.GetNodeValue(var Result: TFPExpressionResult); +begin + inherited GetNodeValue(Result); + Result.ResultType:=rtFloat; + if FCount=0 then + Result.ResFloat:=0 + else + Case FResult.ResultType of + rtInteger: + Result.ResFloat:=FResult.ResInteger/FCount; + rtFloat: + Result.ResFloat:=FResult.ResFloat/FCount; + end; +end; + +{ TAggregateCount } + +procedure TAggregateCount.InitAggregate; +begin + FResult.ResultType:=rtInteger; + FResult.ResInteger:=0; +end; + +procedure TAggregateCount.UpdateAggregate; +begin + Inc(FResult.ResInteger); +end; + +{ TAggregateExpr } + +class function TAggregateExpr.IsAggregate: Boolean; +begin + Result:=True; +end; + +procedure TAggregateExpr.GetNodeValue(var Result: TFPExpressionResult); +begin + Result:=FResult; +end; + +{ TAggregateSum } + + +procedure TAggregateSum.InitAggregate; +begin + FResult.ResultType:=FArgumentNodes[0].NodeType; + Case FResult.ResultType of + rtFloat: FResult.ResFloat:=0.0; + rtinteger: FResult.ResInteger:=0; + end; +end; + +procedure TAggregateSum.UpdateAggregate; + +Var + R : TFPExpressionResult; + +begin + FArgumentNodes[0].GetNodeValue(R); + Case FResult.ResultType of + rtFloat: FResult.ResFloat:=FResult.ResFloat+R.ResFloat; + rtinteger: FResult.ResInteger:=FResult.ResInteger+R.ResInteger; + end; +end; + { --------------------------------------------------------------------- TFPExpressionScanner ---------------------------------------------------------------------} @@ -1014,7 +1155,7 @@ end; TFPExpressionParser ---------------------------------------------------------------------} -Function TFPExpressionParser.TokenType : TTokenType; +function TFPExpressionParser.TokenType: TTokenType; begin Result:=FScanner.TokenType; @@ -1085,13 +1226,13 @@ begin inherited Destroy; end; -Function TFPExpressionParser.GetToken : TTokenType; +function TFPExpressionParser.GetToken: TTokenType; begin Result:=FScanner.GetToken; end; -Procedure TFPExpressionParser.CheckEOF; +procedure TFPExpressionParser.CheckEOF; begin If (TokenType=ttEOF) then @@ -1113,6 +1254,17 @@ begin FExprNode.GetNodeValue(Result); end; +function TFPExpressionParser.ExtractNode(Var N : TFPExprNode) : Boolean; +begin + Result:=Assigned(FExprNode); + if Result then + begin + N:=FExprNode; + FExprNode:=Nil; + FExpression:=''; + end; +end; + procedure TFPExpressionParser.ParserError(Msg: String); begin Raise EExprParser.Create(Msg); @@ -1224,7 +1376,7 @@ end; if the result types differ, they are converted to a common type if possible. } -Procedure TFPExpressionParser.CheckNodes(Var Left,Right : TFPExprNode); +procedure TFPExpressionParser.CheckNodes(var Left, Right: TFPExprNode); begin Left:=MatchNodes(Left,Right); @@ -1238,7 +1390,7 @@ begin FDirty:=True; end; -Function TFPExpressionParser.Level1 : TFPExprNode; +function TFPExpressionParser.Level1: TFPExprNode; var tt: TTokenType; @@ -1458,7 +1610,7 @@ begin ACount:=3 else if IfC then ACount:=-4 - else if (ID.IdentifierType in [itFunctionCallBack,itFunctionHandler]) then + else if (ID.IdentifierType in [itFunctionCallBack,itFunctionHandler,itFunctionNode]) then ACount:=ID.ArgumentCount else ACount:=0; @@ -1510,6 +1662,7 @@ begin itVariable : Result:= TFPExprVariable.CreateIdentifier(ID); itFunctionCallBack : Result:= TFPFunctionCallback.CreateFunction(ID,Args); itFunctionHandler : Result:= TFPFunctionEventHandler.CreateFunction(ID,Args); + itFunctionNode : Result:= ID.NodeType.CreateFunction(ID,Args); end; end; GetToken; @@ -1557,7 +1710,24 @@ function TFPExpressionParser.ResultType: TResultType; begin if not Assigned(FExprNode) then ParserError(SErrInExpression); - Result:=FExprNode.NodeType;; + Result:=FExprNode.NodeType; +end; + +function TFPExpressionParser.HasAggregate: Boolean; +begin + Result:=Assigned(FExprNode) and FExprNode.HasAggregate; +end; + +procedure TFPExpressionParser.InitAggregate; +begin + If Assigned(FExprNode) then + FExprNode.InitAggregate; +end; + +procedure TFPExpressionParser.UpdateAggregate; +begin + If Assigned(FExprNode) then + FExprNode.UpdateAggregate; end; { --------------------------------------------------------------------- @@ -1717,6 +1887,18 @@ begin Result.FOnGetValue:=ACallBack; end; +function TFPExprIdentifierDefs.AddFunction(const AName: ShortString; + const AResultType: Char; const AParamTypes: String; + ANodeClass: TFPExprFunctionClass): TFPExprIdentifierDef; +begin + Result:=Add as TFPExprIdentifierDef; + Result.Name:=Aname; + Result.IdentifierType:=itFunctionNode; + Result.ParameterTypes:=AParamTypes; + Result.ResultType:=CharToResultType(AResultType); + Result.FNodeType:=ANodeClass; +end; + { --------------------------------------------------------------------- TFPExprIdentifierDef ---------------------------------------------------------------------} @@ -2042,6 +2224,14 @@ begin Result.Category:=ACategory; end; +function TExprBuiltInManager.AddFunction(const ACategory: TBuiltInCategory; + const AName: ShortString; const AResultType: Char; const AParamTypes: String; + ANodeClass: TFPExprFunctionClass): TFPBuiltInExprIdentifierDef; +begin + Result:=TFPBuiltInExprIdentifierDef(FDefs.AddFunction(AName,AResultType,AParamTypes,ANodeClass)); + Result. Category:=ACategory; +end; + { --------------------------------------------------------------------- Various Nodes @@ -2075,6 +2265,33 @@ begin inherited Destroy; end; +procedure TFPBinaryOperation.InitAggregate; +begin + inherited InitAggregate; + if Assigned(Left) then + Left.InitAggregate; + if Assigned(Right) then + Right.InitAggregate; +end; + +procedure TFPBinaryOperation.UpdateAggregate; +begin + inherited UpdateAggregate; + if Assigned(Left) then + Left.UpdateAggregate; + if Assigned(Right) then + Right.UpdateAggregate; +end; + +function TFPBinaryOperation.HasAggregate: Boolean; +begin + Result:=inherited HasAggregate; + if Assigned(Left) then + Result:=Result or Left.HasAggregate; + if Assigned(Right) then + Result:=Result or Right.HasAggregate; +end; + procedure TFPBinaryOperation.Check; begin If Not Assigned(Left) then @@ -2096,6 +2313,28 @@ begin inherited Destroy; end; +procedure TFPUnaryOperator.InitAggregate; +begin + inherited InitAggregate; + if Assigned(FOperand) then + FOperand.InitAggregate; + +end; + +procedure TFPUnaryOperator.UpdateAggregate; +begin + inherited UpdateAggregate; + if Assigned(FOperand) then + FOperand.UpdateAggregate; +end; + +function TFPUnaryOperator.HasAggregate: Boolean; +begin + Result:=inherited HasAggregate; + if Assigned(FOperand) then + Result:=Result or FOperand.HasAggregate; +end; + procedure TFPUnaryOperator.Check; begin If Not Assigned(Operand) then @@ -2249,6 +2488,26 @@ begin end; end; +procedure TFPExprNode.InitAggregate; +begin + // Do nothing +end; + +procedure TFPExprNode.UpdateAggregate; +begin + // Do nothing +end; + +function TFPExprNode.HasAggregate: Boolean; +begin + Result:=IsAggregate; +end; + +class function TFPExprNode.IsAggregate: Boolean; +begin + Result:=False; +end; + function TFPExprNode.NodeValue: TFPExpressionResult; begin GetNodeValue(Result); @@ -2354,6 +2613,27 @@ begin CheckSameNodeTypes; end; +procedure TIfOperation.InitAggregate; +begin + inherited InitAggregate; + If Assigned(FCondition) then + fCondition.InitAggregate; +end; + +procedure TIfOperation.UpdateAggregate; +begin + inherited UpdateAggregate; + If Assigned(FCondition) then + FCondition.UpdateAggregate; +end; + +function TIfOperation.HasAggregate: Boolean; +begin + Result:=inherited HasAggregate; + if Assigned(Condition) then + Result:=Result or Condition.HasAggregate; +end; + function TIfOperation.NodeType: TResultType; begin Result:=Left.NodeType; @@ -2432,6 +2712,45 @@ begin end; end; +procedure TCaseOperation.InitAggregate; + +Var + I : Integer; + +begin + inherited InitAggregate; + if Assigned(FCondition) then + FCondition.InitAggregate; + For I:=0 to Length(Fargs)-1 do + FArgs[i].InitAggregate; +end; + +procedure TCaseOperation.UpdateAggregate; +Var + I : Integer; +begin + inherited UpdateAggregate; + if Assigned(FCondition) then + FCondition.UpdateAggregate; + For I:=0 to Length(Fargs)-1 do + FArgs[i].InitAggregate; +end; + +Function TCaseOperation.HasAggregate : Boolean; + +Var + I,L : Integer; +begin + Result:=inherited HasAggregate; + L:=Length(Fargs); + I:=0; + While (Not Result) and (I0 do + begin + FP.UpdateAggregate; + Dec(AUpdateCount); + end; + AssertResult(AResult); +end; + +procedure TTestBuiltins.AssertAggregateExpression(const AExpression: String; + AResult: TExprFloat; 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; + AssertResult(AResult); +end; + procedure TTestBuiltins.TestRegister; begin RegisterStdBuiltins(FM); - AssertEquals('Correct number of identifiers',64,FM.IdentifierCount); + AssertEquals('Correct number of identifiers',67,FM.IdentifierCount); Assertvariable('pi',rtFloat); AssertFunction('cos','F','F',bcMath); AssertFunction('sin','F','F',bcMath); @@ -5217,6 +5614,9 @@ begin AssertFunction('strtotimedef','D','SD',bcConversion); AssertFunction('strtodatetime','D','S',bcConversion); AssertFunction('strtodatetimedef','D','SD',bcConversion); + AssertFunction('sum','F','F',bcAggregate); + AssertFunction('count','I','',bcAggregate); + AssertFunction('avg','F','F',bcAggregate); end; procedure TTestBuiltins.TestVariablepi; @@ -5667,6 +6067,33 @@ begin AssertExpression('StrToDateTimeDef('''+S+''',S)',T); end; +procedure TTestBuiltins.TestFunctionAggregateSum; +begin + FP.Identifiers.AddIntegerVariable('S',2); + AssertAggregateExpression('sum(S)',10.0,5); +end; + +procedure TTestBuiltins.TestFunctionAggregateCount; +begin + AssertAggregateExpression('count',5,5); +end; + + +procedure TTestBuiltins.DoAverage(var Result: TFPExpressionResult; ConstRef + AName: ShortString); + +begin + Inc(FValue); + Result.ResInteger:=FValue; + Result.ResultType:=rtInteger; +end; + +procedure TTestBuiltins.TestFunctionAggregateAvg; +begin + FP.Identifiers.AddVariable('S',rtInteger,@DoAverage); + AssertAggregateExpression('avg(S)',5.5,10); +end; + { TTestNotNode } procedure TTestNotNode.TearDown; @@ -6113,6 +6540,7 @@ initialization TTestParserExpressions, TTestParserBooleanOperations, TTestParserOperands, TTestParserTypeMatch, TTestParserVariables,TTestParserFunctions, + TTestParserAggregate, TTestBuiltinsManager,TTestBuiltins]); end.