* Allow hex, octal and binary notation for expression parser (patch from bug ID #33216)

git-svn-id: trunk@38326 -

packages/fcl-base/src/fpexprpars.pp

@@ -47,6 +47,8 @@ Type
   TFPExprFunction = Class;
   TFPExprFunctionClass = Class of TFPExprFunction;
 
+  TNumberKind = (nkDecimal, nkHex, nkOctal, nkBinary);
+
   { TFPExpressionScanner }
 
   TFPExpressionScanner = Class(TObject)
@@ -62,14 +64,14 @@ Type
   protected
     procedure SetSource(const AValue: String); virtual;
     function DoIdentifier: TTokenType;
-    function DoNumber: TTokenType;
+    function DoNumber(AKind: TNumberKind): TTokenType;
     function DoDelimiter: TTokenType;
     function DoString: TTokenType;
     Function NextPos : Char; // inline;
     procedure SkipWhiteSpace; // inline;
     function IsWordDelim(C : Char) : Boolean; // inline;
     function IsDelim(C : Char) : Boolean; // inline;
-    function IsDigit(C : Char) : Boolean; // inline;
+    function IsDigit(C : Char; AKind: TNumberKind) : Boolean; // inline;
     function IsAlpha(C : Char) : Boolean; // inline;
   public
     Constructor Create;
@@ -591,6 +593,7 @@ Type
   TAggregateExpr = Class(TFPExprFunction)
   Protected
     FResult : TFPExpressionResult;
+  public
     Class Function IsAggregate : Boolean; override;
     Procedure GetNodeValue(var Result : TFPExpressionResult);  override;
   end;
@@ -781,14 +784,23 @@ uses typinfo;
 const
   cNull=#0;
   cSingleQuote = '''';
+  cHexIdentifier = '$';
+  cOctalIdentifier = '&';
+  cBinaryIdentifier = '%';
 
   Digits        = ['0'..'9','.'];
+  HexDigits     = ['0'..'9', 'A'..'F', 'a'..'f'];
+  OctalDigits   = ['0'..'7'];
+  BinaryDigits  = ['0', '1'];
   WhiteSpace    = [' ',#13,#10,#9];
   Operators     = ['+','-','<','>','=','/','*','^'];
   Delimiters    = Operators+[',','(',')'];
   Symbols       = ['%']+Delimiters;
   WordDelimiters = WhiteSpace + Symbols;
 
+var
+  FileFormatSettings: TFormatSettings;
+
 Resourcestring
   SBadQuotes        = 'Unterminated string';
   SUnknownDelimiter = 'Unknown delimiter character: "%s"';
@@ -1115,9 +1127,14 @@ begin
   Result:=C in Delimiters;
 end;
 
-function TFPExpressionScanner.IsDigit(C: Char): Boolean;
+function TFPExpressionScanner.IsDigit(C: Char; AKind: TNumberKind): Boolean;
 begin
-  Result:=C in Digits;
+  case AKind of
+    nkDecimal: Result := C in Digits;
+    nkHex    : Result := C in HexDigits;
+    nkOctal  : Result := C in OctalDigits;
+    nkBinary : Result := C in BinaryDigits;
+  end;
 end;
 
 Procedure TFPExpressionScanner.SkipWhiteSpace;
@@ -1215,7 +1232,21 @@ begin
     Result:=#0;
 end;
 
-Function TFPExpressionScanner.DoNumber : TTokenType;
+procedure Val(const S: string; out V: TExprFloat; out Code: Integer);
+var
+  L64: Int64;
+begin
+  if (S <> '') and (S[1] in ['&', '$', '%']) then
+  begin
+    System.Val(S, L64, Code);
+    if Code = 0 then
+      V := L64
+  end
+  else
+    System.Val(S, V, Code);
+end;
+
+Function TFPExpressionScanner.DoNumber(AKind: TNumberKind) : TTokenType;
 
 Var
   C : Char;
@@ -1223,16 +1254,38 @@ Var
   I : Integer;
   prevC: Char;
 
+  function ValidDigit(C: Char; AKind: TNumberKind): Boolean;
+  begin
+    Result := IsDigit(C, AKind);
+    if (not Result) then
+      case AKind of
+        nkDecimal:
+          Result := ((FToken <> '') and (UpCase(C)='E')) or
+                    ((FToken <> '') and (C in ['+','-']) and (prevC='E'));
+        nkHex:
+          Result := (C = cHexIdentifier) and (prevC = #0);
+        nkOctal:
+          Result := (C = cOctalIdentifier) and (prevC = #0);
+        nkBinary:
+          Result := (C = cBinaryIdentifier) and (prevC = #0);
+      end;
+  end;
+
 begin
   C:=CurrentChar;
   prevC := #0;
-  while (not IsWordDelim(C) or (prevC in ['E','-','+'])) and (C<>cNull) do
+  while (C <> cNull) do
-    begin
+  begin
-    If Not ( IsDigit(C)
+    if IsWordDelim(C) then
-             or ((FToken<>'') and (Upcase(C)='E'))
+      case AKind of
-             or ((FToken<>'') and (C in ['+','-']) and (prevC='E'))
+        nkDecimal:
-           )
+          if not (prevC in ['E','-','+']) then break;
-    then
+        nkHex, nkOctal:
+          break;
+        nkBinary:
+          if (prevC <> #0) then break;   // allow '%' as first char
+      end;
+    if not ValidDigit(C, AKind) then
       ScanError(Format(SErrInvalidNumberChar,[C]));
     FToken := FToken+C;
     prevC := Upcase(C);
@@ -1306,8 +1359,14 @@ begin
     Result:=DoDelimiter
   else if (C=cSingleQuote) then
     Result:=DoString
-  else if IsDigit(C) then
+  else if (C=cHexIdentifier) then
-    Result:=DoNumber
+    Result := DoNumber(nkHex)
+  else if (C=cOctalIdentifier) then
+    Result := DoNumber(nkOctal)
+  else if (C=cBinaryIdentifier) then
+    Result := DoNumber(nkBinary)
+  else if IsDigit(C, nkDecimal) then
+    Result:=DoNumber(nkDecimal)
   else if IsAlpha(C) or (C='"') then
     Result:=DoIdentifier
   else
@@ -2112,8 +2171,8 @@ begin
     Case FValue.ResultType of
       rtBoolean  : FValue.ResBoolean:=FStringValue='True';
       rtInteger  : FValue.ResInteger:=StrToInt(AValue);
-      rtFloat    : FValue.ResFloat:=StrToFloat(AValue);
+      rtFloat    : FValue.ResFloat:=StrToFloat(AValue, FileFormatSettings);
-      rtDateTime : FValue.ResDateTime:=StrToDateTime(AValue);
+      rtDateTime : FValue.ResDateTime:=StrToDateTime(AValue, FileFormatSettings);
       rtString   : FValue.ResString:=AValue;
     end
   else
@@ -2223,8 +2282,8 @@ begin
                  else
                    Result:='False';
     rtInteger  : Result:=IntToStr(FValue.ResInteger);
-    rtFloat    : Result:=FloatToStr(FValue.ResFloat);
+    rtFloat    : Result:=FloatToStr(FValue.ResFloat, FileFormatSettings);
-    rtDateTime : Result:=FormatDateTime('cccc',FValue.ResDateTime);
+    rtDateTime : Result:=FormatDateTime('cccc',FValue.ResDateTime, FileFormatSettings);
     rtString   : Result:=FValue.ResString;
   end;
 end;
@@ -4112,8 +4171,19 @@ begin
     FCategory:=(Source as TFPBuiltInExprIdentifierDef).Category;
 end;
 
+procedure InitFileFormatSettings;
+begin
+  FileFormatSettings := DefaultFormatSettings;
+  FileFormatSettings.DecimalSeparator := '.';
+  FileFormatSettings.DateSeparator := '-';
+  FileFormatSettings.TimeSeparator := ':';
+  FileFormatsettings.ShortDateFormat := 'yyyy-mm-dd';
+  FileFormatSettings.LongTimeFormat := 'hh:nn:ss';
+end;
+
 initialization
   RegisterStdBuiltins(BuiltinIdentifiers);
+  InitFileFormatSettings;
 
 finalization
   FreeBuiltins;

packages/fcl-base/tests/testexprpars.pp

@@ -530,6 +530,7 @@ type
   private
   Published
     Procedure TestCreate;
+    Procedure TestNumberValues;
     Procedure TestSimpleNodeFloat;
     procedure TestSimpleNodeInteger;
     procedure TestSimpleNodeBooleanTrue;
@@ -1320,10 +1321,19 @@ procedure TTestExpressionScanner.TestTokens;
 
 Const
   TestStrings : Array[TTokenType] of String
+  (*
+  TTokenType = (ttPlus, ttMinus, ttLessThan, ttLargerThan, ttEqual, ttDiv,
+                ttMod, ttMul, ttLeft, ttRight, ttLessThanEqual,
+                ttLargerThanEqual, ttunequal, ttNumber, ttString, ttIdentifier,
+                ttComma, ttAnd, ttOr, ttXor, ttTrue, ttFalse, ttNot, ttif,
+                ttCase, ttPower, ttEOF); // keep ttEOF last
+
+  *)
     = ('+','-','<','>','=','/',
-       '*','(',')','<=','>=',
+       'mod','*','(',')','<=',
-       '<>','1','''abc''','abc',',','and',
+       '>=', '<>','1','''abc''','abc',
-       'or','xor','true','false','not','if','case','^','');
+       ',','and', 'or','xor','true','false','not',
+       'if','case','^','');
 
 var
   t : TTokenType;
@@ -1348,17 +1358,23 @@ end;
 
 procedure TTestExpressionScanner.TestNumber;
 begin
-  {TestString('123',ttNumber);
+  TestString('123',ttNumber);
+  TestString('$FF',ttNumber);
+  TestString('&77',ttNumber);
+  TestString('%11111111',ttNumber);
   TestString('123.4',ttNumber);
   TestString('123.E4',ttNumber);
   TestString('1.E4',ttNumber);
   TestString('1e-2',ttNumber);
+  DoInValidNumber('$GG');
+  DoInvalidNumber('&88');
+  DoInvalidNumber('%22');
   DoInvalidNumber('1..1');
-}
   DoInvalidNumber('1.E--1');
 //  DoInvalidNumber('.E-1');
 end;
 
+
 procedure TTestExpressionScanner.TestInvalidCharacter;
 begin
   DoInvalidNumber('~');
@@ -2843,6 +2859,60 @@ begin
   AssertEquals('No identifiers',0,FP.Identifiers.Count);
 end;
 
+procedure TTestParserExpressions.TestNumberValues;
+
+  Procedure DoTest(E :  String; V : integer);
+
+  var
+    res: TFPExpressionResult;
+
+  begin
+    FP.Expression:=E;
+    res := FP.Evaluate;
+    AssertTrue('Expression '+E+': Result is a number', Res.ResultType in [rtInteger,rtFloat]);
+    AssertTrue('Expression '+E+': Correct value', ArgToFloat(res)=V);
+  end;
+
+
+begin
+  // Decimal numbers
+     DoTest('1', 1);
+     DoTest('1E2', 100);
+     DoTest('1.0/1E-2', 100);
+  // DoTest('200%', 2);
+     WriteLn;
+     // Hex numbers
+     DoTest('$0001', 1);
+     DoTest('-$01', -1);
+     DoTest('$A', 10);
+     DoTest('$FF', 255);
+     DoTest('$fe', 254);
+     DoTest('$FFFF', $FFFF);
+     DoTest('1E2', 100);
+     DoTest('$E', 14);
+     DoTest('$D+1E2', 113);
+     DoTest('$0A-$0B', -1);
+     // Hex and variables
+     FP.Identifiers.AddVariable('a', rtInteger, '1');
+     FP.Identifiers.AddVariable('b', rtInteger, '$B');
+     DoTest('a', 1);
+     DoTest('b', $B);
+     DoTest('$A+a', 11);
+     DoTest('$B-b', 0);
+     WriteLn;
+     // Octal numbers
+     DoTest('&10', 8);
+     DoTest('&10+10', 18);
+     // Mixed hex and octal expression
+     DoTest('&10-$0008', 0);
+     WriteLn;
+     // Binary numbers
+     DoTest('%1', 1);
+     DoTest('%11', 3);
+     DoTest('%1000', 8);
+
+end;
+
 
 procedure TTestParserExpressions.TestSimpleNodeFloat;
 begin
@@ -4343,7 +4413,7 @@ begin
   AssertEquals('One variable added',1,FP.Identifiers.Count);
   AssertSame('Result equals variable added',I,FP.Identifiers[0]);
   AssertEquals('Variable has correct resulttype',rtDateTime,I.ResultType);
-  AssertEquals('Variable has correct value',FormatDateTime('cccc',D),I.Value);
+  AssertEquals('Variable has correct value',FormatDateTime('yyyy-mm-dd hh:nn:ss',D),I.Value);
 end;
 
 procedure TTestParserVariables.AddVariabletwice;
@@ -5547,7 +5617,7 @@ begin
   AssertSame('Result equals variable added',I,FM.Identifiers[0]);
   AssertEquals('Variable has correct category',ord(bcUser),Ord(I.Category));
   AssertEquals('Variable has correct resulttype',rtDateTime,I.ResultType);
-  AssertEquals('Variable has correct value',FormatDateTime('cccc',D),I.Value);
+  AssertEquals('Variable has correct value',FormatDateTime('yyyy-mm-dd hh:nn:ss',D),I.Value);
 end;
 
 procedure TTestBuiltinsManager.TestFunction1;
@@ -5720,7 +5790,6 @@ procedure TTestBuiltins.TestRegister;
 
 begin
   RegisterStdBuiltins(FM);
-  AssertEquals('Correct number of identifiers',69,FM.IdentifierCount);
   Assertvariable('pi',rtFloat);
   AssertFunction('cos','F','F',bcMath);
   AssertFunction('sin','F','F',bcMath);
@@ -5785,11 +5854,13 @@ begin
   AssertFunction('strtotimedef','D','SD',bcConversion);
   AssertFunction('strtodatetime','D','S',bcConversion);
   AssertFunction('strtodatetimedef','D','SD',bcConversion);
+  AssertFunction('formatfloat','S','SF',bcConversion);
   AssertFunction('sum','F','F',bcAggregate);
   AssertFunction('count','I','',bcAggregate);
   AssertFunction('avg','F','F',bcAggregate);
   AssertFunction('min','F','F',bcAggregate);
   AssertFunction('max','F','F',bcAggregate);
+  AssertEquals('Correct number of identifiers',70,FM.IdentifierCount);
 end;
 
 procedure TTestBuiltins.TestVariablepi;