fcl-passrc: resolver: eval set of integer range

git-svn-id: trunk@36819 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -47,9 +47,15 @@ Works:
   - error on duplicate in const set
 
 ToDo:
-- set of 1..7
 - arrays
-  - length(), low(), high(), []
+  - length(), [], [a..b], [a,b], +
+  - array of int
+  - of char
+  - of enum
+  - of bool
+  - of record
+  - of string
+- enum ranges: type f=(a,b,c,d); g=b..c;
 }
 unit PasResolveEval;
 
@@ -303,6 +309,33 @@ const
   reitAllSigned = [reitNone,reitShortInt,reitSmallInt,reitIntSingle,reitLongInt,reitIntDouble];
   reitAllUnsigned = [reitByte,reitWord,reitUIntSingle,reitLongWord,reitUIntDouble];
 
+  reitLow: array[TResEvalTypedInt] of MaxPrecInt = (
+    low(MaxPrecInt), // reitNone,
+    low(Byte), // reitByte,
+    low(ShortInt), // reitShortInt,
+    low(Word), // reitWord,
+    low(SmallInt), // reitSmallInt,
+    0, // reitUIntSingle,
+    MinSafeIntSingle, // reitIntSingle,
+    low(LongWord), // reitLongWord,
+    low(LongInt), // reitLongInt,
+    0, // reitUIntDouble,
+    MinSafeIntDouble // reitIntDouble)
+    );
+  reitHigh: array[TResEvalTypedInt] of MaxPrecInt = (
+    high(MaxPrecInt), // reitNone,
+    high(Byte), // reitByte,
+    high(ShortInt), // reitShortInt,
+    high(Word), // reitWord,
+    high(SmallInt), // reitSmallInt,
+    MaxSafeIntSingle, // reitUIntSingle,
+    MaxSafeIntSingle, // reitIntSingle,
+    high(LongWord), // reitLongWord,
+    high(LongInt), // reitLongInt,
+    MaxSafeIntDouble, // reitUIntDouble,
+    MaxSafeIntDouble // reitIntDouble)
+    );
+
 type
   { TResEvalInt }
 
@@ -338,6 +371,7 @@ type
     constructor CreateValue(const aValue: MaxPrecFloat);
     function Clone: TResEvalValue; override;
     function AsString: string; override;
+    function IsInt(out Int: MaxPrecInt): boolean;
   end;
 
   { TResEvalString - Kind=revkString }
@@ -492,6 +526,8 @@ type
     function EvalParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
     function EvalArrayParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
     function EvalSetParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalSet;
+    function EvalSetExpr(Expr: TPasExpr; ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
+    function EvalArrayValuesExpr(Expr: TArrayValues; Flags: TResEvalFlags): TResEvalSet;
     function ExprStringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual;
     function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual;
     procedure PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
@@ -904,32 +940,65 @@ end;
 
 function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags
   ): TResEvalValue;
+var
+  Int: MaxPrecInt;
+  UInt: MaxPrecUInt;
 begin
   Result:=Eval(Expr.Operand,Flags);
   if Result=nil then exit;
+  {$IFDEF VerbosePasResEval}
+  writeln('TResExprEvaluator.EvalUnaryExpr ',OpcodeStrings[Expr.OpCode],' Value=',Result.AsDebugString);
+  {$ENDIF}
   case Expr.OpCode of
     eopAdd: ;
     eopSubtract:
       case Result.Kind of
       revkInt:
         begin
-        if TResEvalInt(Result).Int=0 then exit;
+        Int:=TResEvalInt(Result).Int;
+        if Int=0 then exit;
         if Result.Element<>nil then
           Result:=Result.Clone;
-        if TResEvalInt(Result).Int=0 then exit;
-        if not (TResEvalInt(Result).Typed in reitAllSigned) then
+        if (TResEvalInt(Result).Typed in reitAllSigned) then
+          begin
+          if Int=reitLow[TResEvalInt(Result).Typed] then
+            begin
+            // need higher precision
+            if TResEvalInt(Result).Typed<>reitNone then
+              // unsigned -> switch to untyped
+              TResEvalInt(Result).Typed:=reitNone
+            else
+              begin
+              // switch to float
+              ReleaseEvalValue(Result);
+              Result:=TResEvalFloat.CreateValue(-MaxPrecFloat(low(MaxPrecInt)));
+              exit;
+              end;
+            end;
+          end
+        else
           begin
-          // switch to untyped
+          // unsigned -> switch to untyped
           TResEvalInt(Result).Typed:=reitNone;
-          end;
-        TResEvalInt(Result).Int:=-TResEvalInt(Result).Int
+          end ;
+        // negate
+        TResEvalInt(Result).Int:=-Int;
         end;
       revkUInt:
         begin
-        if TResEvalUInt(Result).UInt=0 then exit;
-        if Result.Element<>nil then
-          Result:=Result.Clone;
-        TResEvalUInt(Result).UInt:=-TResEvalUInt(Result).UInt;
+        UInt:=TResEvalUInt(Result).UInt;
+        if UInt=0 then exit;
+        if UInt<=High(MaxPrecInt) then
+          begin
+          ReleaseEvalValue(Result);
+          Result:=TResEvalInt.CreateValue(-MaxPrecInt(UInt));
+          end
+        else
+          begin
+          // switch to float
+          ReleaseEvalValue(Result);
+          Result:=TResEvalFloat.CreateValue(-MaxPrecFloat(UInt));
+          end;
         end;
       revkFloat:
         begin
@@ -2810,6 +2879,15 @@ end;
 
 function TResExprEvaluator.EvalSetParamsExpr(Expr: TParamsExpr;
   Flags: TResEvalFlags): TResEvalSet;
+begin
+  {$IFDEF VerbosePasResEval}
+  writeln('TResExprEvaluator.EvalSetParamsExpr length(Expr.Params)=',length(Expr.Params));
+  {$ENDIF}
+  Result:=EvalSetExpr(Expr,Expr.Params,Flags);
+end;
+
+function TResExprEvaluator.EvalSetExpr(Expr: TPasExpr;
+  ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
 var
   i: Integer;
   RangeStart, RangeEnd: MaxPrecInt;
@@ -2818,18 +2896,18 @@ var
   El: TPasExpr;
 begin
   {$IFDEF VerbosePasResEval}
-  writeln('TResExprEvaluator.EvalSetParamsExpr length(Expr.Params)=',length(Expr.Params));
+  writeln('TResExprEvaluator.EvalSetExpr Expr=',GetObjName(Expr),' length(ExprArray)=',length(ExprArray));
   {$ENDIF}
   Result:=TResEvalSet.Create;
   Value:=nil;
   OnlyConstElements:=true;
   ok:=false;
   try
-    for i:=0 to length(Expr.Params)-1 do
+    for i:=0 to length(ExprArray)-1 do
       begin
-      El:=Expr.Params[i];
+      El:=ExprArray[i];
       {$IFDEF VerbosePasResEval}
-      writeln('TResExprEvaluator.EvalSetParamsExpr ',i,' of ',length(Expr.Params),' El=',GetObjName(El));
+      writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' El=',GetObjName(El));
       {$ENDIF}
       Value:=Eval(El,Flags);
       if Value=nil then
@@ -2839,7 +2917,7 @@ begin
         continue;
         end;
       {$IFDEF VerbosePasResEval}
-      //writeln('TResExprEvaluator.EvalSetParamsExpr ',i,' of ',length(Expr.Params),' Value=',Value.AsDebugString);
+      //writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' Value=',Value.AsDebugString);
       {$ENDIF}
       case Value.Kind of
       revkBool:
@@ -2904,7 +2982,7 @@ begin
           end
         else if Result.ElKind<>revskEnum then
           RaiseNotYetImplemented(20170713143559,El)
-        else if Result.ElType<>Value.IdentEl.Parent then
+        else if Result.ElType<>TResEvalEnum(Value).ElType then
           RaiseNotYetImplemented(20170713201021,El);
         RangeStart:=TResEvalEnum(Value).Index;
         RangeEnd:=RangeStart;
@@ -2937,7 +3015,7 @@ begin
         end
       else
         {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
-        writeln('TResExprEvaluator.EvalSetParamsExpr Result.ElKind=',Result.ElKind,' Value.Kind=',Value.Kind);
+        writeln('TResExprEvaluator.EvalSetExpr Result.ElKind=',Result.ElKind,' Value.Kind=',Value.Kind);
         {$ENDIF}
         RaiseNotYetImplemented(20170713143422,El);
       end;
@@ -2945,7 +3023,7 @@ begin
       if Result.Intersects(RangeStart,RangeEnd)>=0 then
         begin
         {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
-        writeln('TResExprEvaluator.EvalSetParamsExpr Value=',Value.AsDebugString,' Range=',RangeStart,'..',RangeEnd,' Result=',Result.AsDebugString);
+        writeln('TResExprEvaluator.EvalSetExpr Value=',Value.AsDebugString,' Range=',RangeStart,'..',RangeEnd,' Result=',Result.AsDebugString);
         {$ENDIF}
         RaiseMsg(20170714141326,nRangeCheckInSetConstructor,
           sRangeCheckInSetConstructor,[],El);
@@ -2960,6 +3038,15 @@ begin
   end;
 end;
 
+function TResExprEvaluator.EvalArrayValuesExpr(Expr: TArrayValues;
+  Flags: TResEvalFlags): TResEvalSet;
+begin
+  {$IFDEF VerbosePasResEval}
+  writeln('TResExprEvaluator.EvalArrayValuesExpr length(Expr.Values)=',length(Expr.Values));
+  {$ENDIF}
+  Result:=EvalSetExpr(Expr,Expr.Values,Flags);
+end;
+
 function TResExprEvaluator.EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue,
   RightValue: TResEvalValue): TResEvalValue;
 var
@@ -3276,7 +3363,7 @@ begin
       pekIdent:
         begin
         Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags);
-        writeln('TResExprEvaluator.Eval primitiv result=',Result<>nil,' ',dbgs(Result));
+        //writeln('TResExprEvaluator.Eval primitiv result=',Result<>nil,' ',dbgs(Result));
         end;
       pekNumber:
         begin
@@ -3284,6 +3371,11 @@ begin
         val(TPrimitiveExpr(Expr).Value,Int,Code);
         if Code=0 then
           begin
+          {$IFDEF VerbosePasResEval}
+          writeln('TResExprEvaluator.Eval Int=',Int,' Value="',TPrimitiveExpr(Expr).Value,'"');
+          {$ENDIF}
+          if (Int<0) and (Pos('-',TPrimitiveExpr(Expr).Value)<1) then
+            RaiseInternalError(20170802141254,'bug in FPC str()');
           Result:=TResEvalInt.CreateValue(Int);
           exit;
           end;
@@ -3292,6 +3384,9 @@ begin
         if Code=0 then
           begin
           Result:=TResEvalUInt.CreateValue(UInt);
+          {$IFDEF VerbosePasResEval}
+          writeln('TResExprEvaluator.Eval UInt=',UInt,' Value="',TPrimitiveExpr(Expr).Value,'"');
+          {$ENDIF}
           exit;
           end;
         // try float
@@ -3299,6 +3394,9 @@ begin
         if Code=0 then
           begin
           Result:=TResEvalFloat.CreateValue(Flo);
+          {$IFDEF VerbosePasResEval}
+          writeln('TResExprEvaluator.Eval Float=',Flo,' Value="',TPrimitiveExpr(Expr).Value,'"');
+          {$ENDIF}
           exit;
           end;
         RaiseRangeCheck(20170518202252,Expr);
@@ -3323,6 +3421,8 @@ begin
     Result:=EvalBinaryExpr(TBinaryExpr(Expr),Flags)
   else if C=TParamsExpr then
     Result:=EvalParamsExpr(TParamsExpr(Expr),Flags)
+  else if C=TArrayValues then
+    Result:=EvalArrayValuesExpr(TArrayValues(Expr),Flags)
   else if refConst in Flags then
     RaiseConstantExprExp(20170518213800,Expr);
   writeln('TResExprEvaluator.Eval END ',Expr.ClassName,' result=',Result<>nil,' ',dbgs(Result));
@@ -4225,6 +4325,16 @@ begin
   str(FloatValue,Result);
 end;
 
+function TResEvalFloat.IsInt(out Int: MaxPrecInt): boolean;
+begin
+  Int:=0;
+  if Frac(FloatValue)<>0 then exit(false);
+  if FloatValue<MaxPrecFloat(low(MaxPrecInt)) then exit(false);
+  if FloatValue>MaxPrecFloat(high(MaxPrecInt)) then exit(false);
+  Int:=Trunc(FloatValue);
+  Result:=true;
+end;
+
 { TResEvalString }
 
 constructor TResEvalString.Create;

packages/fcl-passrc/src/pasresolver.pp

@@ -137,9 +137,7 @@ Works:
 - dotted unitnames
 - eval:
   - nil, true, false
-
-ToDo:
-- range checking:
+  - range checking:
   - integer ranges
   - boolean ranges
   - enum ranges
@@ -148,12 +146,16 @@ ToDo:
   - =, <>, <, <=, >, >=
   - ord(), low(), high(), pred(), succ(), length()
   - string[index]
-  - arr[index]
   - call(param)
-  - indexedprop[param]
   - a:=value
-  - set+set, set*set, set-set
+
+ToDo:
+- range checking:
+  - arr[index]
+  - indexedprop[param]
   - case-of unique
+  - defaultvalue
+  - stored
 - @@
 - fail to write a loop var inside the loop
 - warn: create class with abstract methods
@@ -1367,7 +1369,7 @@ type
     function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
     function IsTypeCast(Params: TParamsExpr): boolean;
     function ProcNeedsParams(El: TPasProcedureType): boolean;
-    function GetRangeLength(RangeResolved: TPasResolverResult): integer;
+    function GetRangeLength(const RangeResolved: TPasResolverResult): MaxPrecInt;
     function HasTypeInfo(El: TPasType): boolean; virtual;
     function GetActualBaseType(bt: TResolverBaseType): TResolverBaseType; virtual;
     function GetCombinedBoolean(Bool1, Bool2: TResolverBaseType; ErrorEl: TPasElement): TResolverBaseType; virtual;
@@ -1652,6 +1654,8 @@ procedure SetResolverIdentifier(out ResolvedType: TPasResolverResult;
   BaseType: TResolverBaseType; IdentEl: TPasElement; TypeEl: TPasType;
   Flags: TPasResolverResultFlags);
 begin
+  if IdentEl is TPasExpr then
+    raise Exception.Create('20170729101017');
   ResolvedType.BaseType:=BaseType;
   ResolvedType.SubType:=btNone;
   ResolvedType.IdentEl:=IdentEl;
@@ -6437,6 +6441,7 @@ begin
           ResolvedEl:=LeftResolved;
           ResolvedEl.SubType:=ResolvedEl.BaseType;
           ResolvedEl.BaseType:=btRange;
+          ResolvedEl.ExprEl:=Bin;
           exit;
           end;
         end;
@@ -10977,7 +10982,22 @@ begin
             or (MaxVal<MaxPrecInt(TResEvalUInt(RValue).UInt)) then
           fExprEvaluator.EmitRangeCheckConst(20170530093616,
             IntToStr(TResEvalUInt(RValue).UInt),IntToStr(MinVal),IntToStr(MaxVal),RHS);
+      revkFloat:
+        if TResEvalFloat(RValue).IsInt(Int) then
+          begin
+          if (MinVal>Int) or (MaxVal<Int) then
+            fExprEvaluator.EmitRangeCheckConst(20170802133307,
+              IntToStr(Int),MinVal,MaxVal,RHS,mtError);
+          end
+        else
+          begin
+          writeln('AAA1 TPasResolver.CheckAssignExprRange ',Frac(TResEvalFloat(RValue).FloatValue),' ',TResEvalFloat(RValue).FloatValue<MaxPrecFloat(low(MaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue>MaxPrecFloat(high(MaxPrecInt)),' ',TResEvalFloat(RValue).FloatValue,' ',high(MaxPrecInt));
+          RaiseRangeCheck(20170802133750,RHS);
+          end;
       else
+        {$IFDEF VerbosePasResEval}
+        writeln('TPasResolver.CheckAssignExprRange ',RValue.AsDebugString);
+        {$ENDIF}
         RaiseNotYetImplemented(20170530092731,RHS);
       end
     else if LeftResolved.BaseType=btQWord then
@@ -11283,23 +11303,28 @@ begin
       Result:=CheckAssignCompatibilityArrayType(LHS,RHS,ErrorEl,RaiseOnIncompatible);
     end;
 
-  {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.CheckAssignResCompatibility incompatible LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
-  {$ENDIF}
   if (Result>=0) and (Result<cIncompatible) then
     begin
     // type fits -> check readable
     if not (rrfReadable in RHS.Flags) then
       begin
       if RaiseOnIncompatible then
+        begin
+        {$IFDEF VerbosePasResolver}
+        writeln('TPasResolver.CheckAssignResCompatibility RHS not readable. LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
+        {$ENDIF}
         RaiseMsg(20170318235637,nVariableIdentifierExpected,
           sVariableIdentifierExpected,[],ErrorEl);
+        end;
       exit(cIncompatible);
       end;
     exit;
     end;
 
   // incompatible
+  {$IFDEF VerbosePasResolver}
+  writeln('TPasResolver.CheckAssignResCompatibility incompatible LHS='+GetResolverResultDbg(LHS)+' RHS='+GetResolverResultDbg(RHS));
+  {$ENDIF}
   if not RaiseOnIncompatible then
     exit(cIncompatible);
 
@@ -12046,7 +12071,7 @@ function TPasResolver.CheckAssignCompatibilityArrayType(const LHS,
     if IsLastRange then
       begin
       ComputeElement(ArrType.ElType,ElTypeResolved,[rcType]);
-      ElTypeResolved.IdentEl:=Range;
+      ElTypeResolved.ExprEl:=Range;
       Include(ElTypeResolved.Flags,rrfWritable);
       end
     else
@@ -12997,6 +13022,8 @@ begin
     begin
     ComputeElement(TPasRangeType(El).RangeExpr,ResolvedEl,[rcConstant],StartEl);
     ResolvedEl.IdentEl:=El;
+    if ResolvedEl.ExprEl=nil then
+      ResolvedEl.ExprEl:=TPasRangeType(El).RangeExpr;
     ResolvedEl.Flags:=[];
     end
   else if ElClass=TPasSetType then
@@ -13380,17 +13407,57 @@ begin
   Result:=(El.Args.Count>0) and (TPasArgument(El.Args[0]).ValueExpr=nil);
 end;
 
-function TPasResolver.GetRangeLength(RangeResolved: TPasResolverResult
-  ): integer;
+function TPasResolver.GetRangeLength(const RangeResolved: TPasResolverResult
+  ): MaxPrecInt;
+var
+  TypeEl: TPasType;
+  {$IFDEF EnablePasResRangeCheck}
+  Value: TResEvalValue;
+  {$ENDIF}
 begin
   Result:=0;
   if RangeResolved.BaseType=btContext then
     begin
-    if RangeResolved.IdentEl is TPasEnumType then
-      Result:=TPasEnumType(RangeResolved.IdentEl).Values.Count;
+    if RangeResolved.IdentEl is TPasType then
+      begin
+      TypeEl:=ResolveAliasType(TPasType(RangeResolved.IdentEl));
+      if TypeEl<>nil then
+        begin
+        if TypeEl.ClassType=TPasEnumType then
+          Result:=TPasEnumType(TypeEl).Values.Count;
+        end;
+      end;
+    end
+  else if RangeResolved.ExprEl<>nil then
+    begin
+    {$IFDEF EnablePasResRangeCheck}
+    Value:=Eval(RangeResolved.ExprEl,[]);
+    if Value=nil then
+      RaiseMsg(20170729094135,nIncompatibleTypesGotExpected,
+        sIncompatibleTypesGotExpected,
+        [GetResolverResultDescription(RangeResolved),'range'],RangeResolved.ExprEl);
+    try
+      case Value.Kind of
+        revkRangeInt:
+          Result:=TResEvalRangeInt(Value).RangeEnd-TResEvalRangeInt(Value).RangeStart+1;
+      else
+        RaiseMsg(20170729093823,nIncompatibleTypesGotExpected,
+          sIncompatibleTypesGotExpected,
+          [GetResolverResultDescription(RangeResolved),'range'],RangeResolved.ExprEl);
+      end;
+    finally
+      ReleaseEvalValue(Value);
+    end;
+    {$ELSE}
+    Result:=2;
+    {$ENDIF}
     end
   else if RangeResolved.BaseType in btAllBooleans then
     Result:=2;
+  {$IFDEF VerbosePasResolver}
+  //if Result=0 then
+    writeln('TPasResolver.GetRangeLength ',GetResolverResultDbg(RangeResolved),' Result=',Result);
+  {$ENDIF}
 end;
 
 function TPasResolver.HasTypeInfo(El: TPasType): boolean;

packages/fcl-passrc/tests/tcresolver.pas

@@ -237,6 +237,7 @@ type
     Procedure TestEnumSet_AnonymousEnumtype;
     Procedure TestEnumSet_AnonymousEnumtypeName;
     Procedure TestEnumSet_Const;
+    Procedure TestSet_IntRange_Const;
 
     // operators
     Procedure TestPrgAssignment;
@@ -552,6 +553,7 @@ type
     Procedure TestArray_TypeCastWrongElTypeFail;
     Procedure TestArray_ConstDynArrayWrite;
     Procedure TestArray_ConstOpenArrayWriteFail;
+    Procedure TestArray_Static_Const;
 
     // static arrays
     Procedure TestArrayIntRange_OutOfRange;
@@ -3022,6 +3024,21 @@ begin
   CheckResolverUnexpectedHints;
 end;
 
+procedure TTestResolver.TestSet_IntRange_Const;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TIntRg = 2..6;',
+  '  TSevenSet = set of TIntRg;',
+  'const',
+  '  a: TSevenSet = [2..3,5]+[4];',
+  '  b = low(TIntRg)+high(TIntRg);',
+  'begin']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+end;
+
 procedure TTestResolver.TestPrgAssignment;
 var
   El: TPasElement;
@@ -8916,6 +8933,22 @@ begin
   CheckResolverException('Variable identifier expected',nVariableIdentifierExpected);
 end;
 
+procedure TTestResolver.TestArray_Static_Const;
+begin
+  {$IFDEF EnablePasResRangeCheck}
+  StartProgram(false);
+  Add([
+  'type',
+  '  TIntArr = array[1..3] of longint;',
+  'const',
+  '  a = low(TIntArr)+high(TIntArr);',
+  '  b: array[1..3] of longint = (10,11,12);',
+  'begin']);
+  ParseProgram;
+  CheckResolverUnexpectedHints;
+  {$ENDIF}
+end;
+
 procedure TTestResolver.TestArrayIntRange_OutOfRange;
 begin
   StartProgram(false);