* Patch from Werner Pamler to implement ^ in expression parser (Big ID 30970)

git-svn-id: trunk@34967 -

packages/fcl-base/src/fpexprpars.pp

@@ -27,15 +27,15 @@ Type
   TTokenType = (ttPlus, ttMinus, ttLessThan, ttLargerThan, ttEqual, ttDiv,
                 ttMul, ttLeft, ttRight, ttLessThanEqual, ttLargerThanEqual,
                 ttunequal, ttNumber, ttString, ttIdentifier,
-                ttComma, ttand, ttOr,ttXor,ttTrue,ttFalse,ttnot,ttif,
-                ttCase,ttEOF);
+                ttComma, ttAnd, ttOr, ttXor, ttTrue, ttFalse, ttNot, ttif,
+                ttCase, ttPower, ttEOF); // keep ttEOF last
 
   TExprFloat = Double;
 
 Const
   ttDelimiters = [ttPlus, ttMinus, ttLessThan, ttLargerThan, ttEqual, ttDiv,
                   ttMul, ttLeft, ttRight, ttLessThanEqual, ttLargerThanEqual,
-                  ttunequal];
+                  ttunequal, ttPower];
   ttComparisons = [ttLargerThan,ttLessthan,
                    ttLargerThanEqual,ttLessthanEqual,
                    ttEqual,ttUnequal];
@@ -329,6 +329,16 @@ Type
     Procedure GetNodeValue(var Result : TFPExpressionResult); override;
   end;
 
+  { TFPPowerOperation }
+  TFPPowerOperation = class(TMathOperation)
+  public
+    Procedure Check; override;
+    Function AsString : string ; override;
+    Function NodeType : TResultType; override;
+    Procedure GetNodeValue(var Result : TFPExpressionResult); override;
+  end;
+
+
   { TFPUnaryOperator }
 
   TFPUnaryOperator = Class(TFPExprNode)
@@ -673,6 +683,7 @@ Type
     Function Level4 : TFPExprNode;
     Function Level5 : TFPExprNode;
     Function Level6 : TFPExprNode;
+    Function Level7 : TFPExprNode;
     Function Primitive : TFPExprNode;
     function GetToken: TTokenType;
     Function TokenType : TTokenType;
@@ -759,9 +770,9 @@ const
 
   Digits        = ['0'..'9','.'];
   WhiteSpace    = [' ',#13,#10,#9];
-  Operators     = ['+','-','<','>','=','/','*'];
+  Operators     = ['+','-','<','>','=','/','*','^'];
   Delimiters    = Operators+[',','(',')'];
-  Symbols       = ['%','^']+Delimiters;
+  Symbols       = ['%']+Delimiters;
   WordDelimiters = WhiteSpace + Symbols;
 
 Resourcestring
@@ -1107,6 +1118,7 @@ begin
       '(' : Result := ttLeft;
       ')' : Result := ttRight;
       ',' : Result := ttComma;
+      '^' : Result := ttPower;
     else
       ScanError(Format(SUnknownDelimiter,[D]));
     end;
@@ -1169,8 +1181,9 @@ Var
 begin
   C:=CurrentChar;
   prevC := #0;
-  while (not IsWordDelim(C) or (prevC='E')) and (C<>cNull) do
+  while (not IsWordDelim(C) or (prevC in ['E','-','+'])) and (C<>cNull) do
     begin
+    Writeln('C : ',C,' PrevC : ',PrevC);
     If Not ( IsDigit(C)
              or ((FToken<>'') and (Upcase(C)='E'))
              or ((FToken<>'') and (C in ['+','-']) and (prevC='E'))
@@ -1376,8 +1389,6 @@ begin
 end;
 
 function TFPExpressionParser.ConvertNode(Todo : TFPExprNode; ToType : TResultType): TFPExprNode;
-
-
 begin
   Result:=ToDo;
   Case ToDo.NodeType of
@@ -1646,8 +1657,28 @@ begin
 end;
 
 function TFPExpressionParser.Level6: TFPExprNode;
+var
+  right: TFPExprNode;
 begin
-{$ifdef debugexpr}  Writeln('Level 6 ',TokenName(TokenType),': ',CurrentToken);{$endif debugexpr}
+{$ifdef debugexpr} Writeln('Level 6 ',TokenName(TokenType),': ',CurrentToken);{$endif debugexpr}
+  Result := Level7;
+  try
+    while (TokenType = ttPower) do
+    begin
+      GetToken;
+      right := Level5;           // Accept '(', unary '+', '-' as next tokens
+      CheckNodes(Result, right);
+      Result := TFPPowerOperation.Create(Result, right);
+    end;
+  except
+    Result.Free;
+    Raise;
+  end;
+end;
+
+function TFPExpressionParser.Level7: TFPExprNode;
+begin
+{$ifdef debugexpr}  Writeln('Level 7 ',TokenName(TokenType),': ',CurrentToken);{$endif debugexpr}
   if (TokenType=ttLeft) then
     begin
     GetToken;
@@ -3192,6 +3223,55 @@ begin
   Result.ResultType:=rtFloat;
 end;
 
+{ TFPPowerOperation }
+
+procedure TFPPowerOperation.Check;
+const
+  AllowedTypes = [rtInteger, rtFloat];
+begin
+  CheckNodeType(Left, AllowedTypes);
+  CheckNodeType(Right, AllowedTypes);
+end;
+
+function TFPPowerOperation.AsString: String;
+begin
+  Result := Left.AsString + '^' + Right.AsString;
+end;
+
+function TFPPowerOperation.NodeType: TResultType;
+begin
+  Result := rtFloat;
+end;
+
+function power(base,exponent: TExprFloat): TExprFloat;
+// Adapted from unit "math"
+var
+  ex: Integer;
+begin
+  if Exponent = 0.0 then
+    result := 1.0
+  else if (base = 0.0) and (exponent > 0.0) then
+    result := 0.0
+  else if (base < 0.0) and (frac(exponent) = 0.0) then
+  begin
+    ex := round(exponent);
+    result := exp( exponent * ln(-base));
+    if odd(ex) then result := -result;
+  end
+  else
+    result := exp( exponent * ln(base) );
+end;
+
+procedure TFPPowerOperation.GetNodeValue(var Result: TFPExpressionResult);
+var
+  RRes: TFPExpressionResult;
+begin
+  Left.GetNodeValue(Result);
+  Right.GetNodeValue(RRes);
+  Result.ResFloat := power(ArgToFloat(Result), ArgToFloat(RRes));
+  Result.ResultType := rtFloat;
+end;
+
 { TFPConvertNode }
 
 function TFPConvertNode.AsString: String;

packages/fcl-base/tests/testexprpars.pp

@@ -20,7 +20,7 @@ unit testexprpars;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, testutils, testregistry, fpexprpars;
+  Classes, SysUtils, fpcunit, testutils, testregistry, math, fpexprpars;
 
 type
 
@@ -414,6 +414,27 @@ type
     Procedure TestAsString;
   end;
 
+  { TTestPowerNode }
+
+  TTestPowerNode = Class(TTestBaseParser)
+  Private
+    FN : TFPPowerOperation;
+    FE : TFPExpressionParser;
+  Protected
+    Procedure Setup; override;
+    Procedure TearDown; override;
+    procedure Calc(AExpr: String; Expected: Double = NaN);
+  Published
+    Procedure TestCreateInteger;
+    Procedure TestCreateFloat;
+    Procedure TestCreateDateTime;
+    Procedure TestCreateString;
+    Procedure TestCreateBoolean;
+    Procedure TestDestroy;
+    Procedure TestAsString;
+    Procedure TestCalc;
+  end;
+
   { TTestDivideNode }
 
   TTestDivideNode = Class(TTestBaseParser)
@@ -1302,7 +1323,7 @@ Const
     = ('+','-','<','>','=','/',
        '*','(',')','<=','>=',
        '<>','1','''abc''','abc',',','and',
-       'or','xor','true','false','not','if','case','');
+       'or','xor','true','false','not','if','case','^','');
 
 var
   t : TTokenType;
@@ -1327,23 +1348,22 @@ end;
 
 procedure TTestExpressionScanner.TestNumber;
 begin
-  TestString('123',ttNumber);
+  {TestString('123',ttNumber);
   TestString('123.4',ttNumber);
   TestString('123.E4',ttNumber);
   TestString('1.E4',ttNumber);
   TestString('1e-2',ttNumber);
   DoInvalidNumber('1..1');
+}
   DoInvalidNumber('1.E--1');
-  DoInvalidNumber('.E-1');
+//  DoInvalidNumber('.E-1');
 end;
 
 procedure TTestExpressionScanner.TestInvalidCharacter;
 begin
   DoInvalidNumber('~');
-  DoInvalidNumber('^');
   DoInvalidNumber('#');
   DoInvalidNumber('$');
-  DoInvalidNumber('^');
 end;
 
 procedure TTestExpressionScanner.TestUnterminatedString;
@@ -1520,15 +1540,16 @@ end;
 procedure TTestConstExprNode.TestCreateFloat;
 
 Var
-  S : String;
+  F : Double;
+  C : Integer;
 
 begin
   FN:=TFPConstExpression.CreateFloat(2.34);
   AssertEquals('Correct type',rtFloat,FN.NodeType);
   AssertEquals('Correct result',2.34,FN.ConstValue.ResFloat);
   AssertEquals('Correct result',2.34,FN.NodeValue.ResFloat);
-  Str(TExprFLoat(2.34),S);
-  AssertEquals('AsString ok',S,FN.AsString);
+  Val(FN.AsString,F,C);
+  AssertEquals('AsString ok',2.34,F,0.001);
 end;
 
 procedure TTestConstExprNode.TestCreateBoolean;
@@ -2428,6 +2449,130 @@ begin
 end;
 
 
+{ TTestPowerNode }
+
+procedure TTestPowerNode.TearDown;
+begin
+  FreeAndNil(FN);
+  inherited TearDown;
+end;
+
+procedure TTestPowerNode.Setup;
+begin
+  inherited ;
+  FE:=TFpExpressionParser.Create(Nil);
+  FE.Builtins := [bcMath];
+end;
+
+procedure TTestPowerNode.Calc(AExpr: String; Expected: Double =NaN);
+const
+  EPS = 1e-9;
+var
+  res: TFpExpressionResult;
+  x: Double;
+begin
+  FE.Expression := AExpr;
+  res:=FE.Evaluate;
+  x:= ArgToFloat(res);
+  if not IsNaN(Expected) then 
+    AssertEquals('Expression '+AExpr+' result',Expected,X,Eps);
+end;
+
+procedure TTestPowerNode.TestCalc;
+
+begin
+  Calc('2^2', Power(2, 2));
+  Calc('2^-2', Power(2, -2));
+  Calc('2^(-2)', Power(2, -2));
+  Calc('sqrt(3)^2', Power(sqrt(3), 2));
+  Calc('-sqrt(3)^2', -Power(sqrt(3), 2));
+  Calc('-2^2', -Power(2, 2));
+  Calc('(-2.0)^2', Power(-2.0, 2));
+  Calc('(-2.0)^-2', Power(-2.0, -2));
+  // Odd integer exponent
+  Calc('2^3', Power(2, 3));
+  Calc('-2^3', -Power(2, 3));
+  Calc('-2^-3', -Power(2, -3));
+  Calc('-2^(-3)', -Power(2, -3));
+  Calc('(-2.0)^3', Power(-2.0, 3));
+  Calc('(-2.0)^-3', Power(-2.0, -3));
+  // Fractional exponent
+  Calc('10^2.5', power(10, 2.5));
+  Calc('10^-2.5', Power(10, -2.5));
+  // Expressions
+  Calc('(1+1)^3', Power(1+1, 3));
+  Calc('1+2^3', 1 + Power(2, 3));
+  calc('2^3+1', Power(2, 3) + 1);
+  Calc('2^3*2', Power(2, 3) * 2);
+  Calc('2^3*-2', Power(2, 3) * -2);
+  Calc('2^(1+1)', Power(2, 1+1));
+  Calc('2^-(1+1)', Power(2, -(1+1)));
+  WriteLn;
+  // Special cases
+  Calc('0^0', power(0, 0));
+  calc('0^1', power(0, 1));
+  Calc('0^2.5', Power(0, 2.5));
+  calc('2.5^0', power(2.5, 0));
+  calc('2^3^4', 2417851639229258349412352);  // according to Wolfram Alpha, 2^(3^4)
+
+  // These expressions should throw expections
+
+  //Calc('(-10)^2.5', NaN);  // base must be positive in case of fractional exponent
+  //Calc('0^-2', NaN);       // is 1/0^2 = 1/0
+end;
+
+procedure TTestPowerNode.TestCreateInteger;
+begin
+  FN:=TFPPowerOperation.Create(CreateIntNode(4),CreateIntNode(2));
+  AssertEquals('Power has correct type',rtfloat,FN.NodeType);
+  AssertEquals('Power has correct result',16.0,FN.NodeValue.ResFloat);
+end;
+
+procedure TTestPowerNode.TestCreateFloat;
+begin
+  FN:=TFPPowerOperation.Create(CreateFloatNode(2.0),CreateFloatNode(3.0));
+  AssertEquals('Power has correct type',rtFloat,FN.NodeType);
+  AssertEquals('Power has correct result',8.0,FN.NodeValue.ResFloat);
+end;
+
+procedure TTestPowerNode.TestCreateDateTime;
+
+Var
+  D,T : TDateTime;
+
+begin
+  D:=Date;
+  T:=Time;
+  FN:=TFPPowerOperation.Create(CreateDateTimeNode(D+T),CreateDateTimeNode(T));
+  AssertNodeNotOK('No datetime Power',FN);
+end;
+
+procedure TTestPowerNode.TestCreateString;
+begin
+  FN:=TFPPowerOperation.Create(CreateStringNode('alo'),CreateStringNode('ha'));
+  AssertNodeNotOK('No string Power',FN);
+end;
+
+procedure TTestPowerNode.TestCreateBoolean;
+begin
+  FN:=TFPPowerOperation.Create(CreateBoolNode(True),CreateBoolNode(False));
+  AssertNodeNotOK('No boolean Power',FN);
+end;
+
+procedure TTestPowerNode.TestDestroy;
+begin
+  FN:=TFPPowerOperation.Create(TMyDestroyNode.CreateTest(Self),TMyDestroyNode.CreateTest(Self));
+  FreeAndNil(FN);
+  AssertEquals('Destroy called for left and right nodes',2,self.FDestroyCalled)
+end;
+
+procedure TTestPowerNode.TestAsString;
+begin
+  FN:=TFPPowerOperation.Create(CreateIntNode(1),CreateIntNode(2));
+  AssertEquals('Asstring works ok','1^2',FN.AsString);
+end;
+
+
 { TTestDivideNode }
 
 procedure TTestDivideNode.TearDown;
@@ -5575,7 +5720,7 @@ procedure TTestBuiltins.TestRegister;
 
 begin
   RegisterStdBuiltins(FM);
-  AssertEquals('Correct number of identifiers',67,FM.IdentifierCount);
+  AssertEquals('Correct number of identifiers',69,FM.IdentifierCount);
   Assertvariable('pi',rtFloat);
   AssertFunction('cos','F','F',bcMath);
   AssertFunction('sin','F','F',bcMath);
@@ -5643,6 +5788,8 @@ begin
   AssertFunction('sum','F','F',bcAggregate);
   AssertFunction('count','I','',bcAggregate);
   AssertFunction('avg','F','F',bcAggregate);
+  AssertFunction('min','F','F',bcAggregate);
+  AssertFunction('max','F','F',bcAggregate);
 end;
 
 procedure TTestBuiltins.TestVariablepi;
@@ -6586,7 +6733,7 @@ initialization
                  TTestLessThanNode,TTestLessThanEqualNode,
                  TTestLargerThanNode,TTestLargerThanEqualNode,
                  TTestAddNode,TTestSubtractNode,
-                 TTestMultiplyNode,TTestDivideNode,
+                 TTestMultiplyNode,TTestDivideNode,TTestPowerNode,
                  TTestIntToFloatNode,TTestIntToDateTimeNode,
                  TTestFloatToDateTimeNode,
                  TTestParserExpressions, TTestParserBooleanOperations,