Browse Source

fcl-passrc: more const operators

git-svn-id: trunk@36376 -
Mattias Gaertner 8 years ago
parent
commit
9ff7e70ffc

File diff suppressed because it is too large
+ 770 - 166
packages/fcl-passrc/src/pasresolveeval.pas


+ 151 - 27
packages/fcl-passrc/src/pasresolver.pp

@@ -144,13 +144,15 @@ ToDo:
   - boolean ranges
   - boolean ranges
   - enum ranges
   - enum ranges
   - char ranges
   - char ranges
-  - +, -, *, div, mod, /, shl, shr, or, and, xor
+  - +, -, *, div, mod, /, shl, shr, or, and, xor, in, ^^, ><
+  - =, <>, <, <=, >, >=
   - ord(), low(), high(), pred(), succ(), length()
   - ord(), low(), high(), pred(), succ(), length()
   - string[index]
   - string[index]
   - arr[index]
   - arr[index]
   - call(param)
   - call(param)
   - indexedprop[param]
   - indexedprop[param]
   - a:=value
   - a:=value
+  - set+set, set*set, set-set
 - @@
 - @@
 - fail to write a loop var inside the loop
 - fail to write a loop var inside the loop
 - warn: create class with abstract methods
 - warn: create class with abstract methods
@@ -840,6 +842,8 @@ type
     Exp: TPasExpr; RaiseOnError: boolean): integer of object;
     Exp: TPasExpr; RaiseOnError: boolean): integer of object;
   TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
   TOnGetCallResult = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
     out ResolvedEl: TPasResolverResult) of object;
     out ResolvedEl: TPasResolverResult) of object;
+  TOnEvalBIFunction = procedure(Proc: TResElDataBuiltInProc; Params: TParamsExpr;
+    out Evaluated: TResEvalValue) of object;
   TOnFinishParamsExpr = procedure(Proc: TResElDataBuiltInProc;
   TOnFinishParamsExpr = procedure(Proc: TResElDataBuiltInProc;
     Params: TParamsExpr) of object;
     Params: TParamsExpr) of object;
 
 
@@ -857,6 +861,7 @@ type
     BuiltIn: TResolverBuiltInProc;
     BuiltIn: TResolverBuiltInProc;
     GetCallCompatibility: TOnGetCallCompatibility;
     GetCallCompatibility: TOnGetCallCompatibility;
     GetCallResult: TOnGetCallResult;
     GetCallResult: TOnGetCallResult;
+    Eval: TOnEvalBIFunction;
     FinishParamsExpression: TOnFinishParamsExpr;
     FinishParamsExpression: TOnFinishParamsExpr;
     Flags: TBuiltInProcFlags;
     Flags: TBuiltInProcFlags;
   end;
   end;
@@ -1101,6 +1106,8 @@ type
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     procedure BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc;
     procedure BI_Length_OnGetCallResult(Proc: TResElDataBuiltInProc;
       Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
       Params: TParamsExpr; out ResolvedEl: TPasResolverResult); virtual;
+    procedure BI_Length_OnEval(Proc: TResElDataBuiltInProc;
+      Params: TParamsExpr; out Evaluated: TResEvalValue); virtual;
     function BI_SetLength_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
     function BI_SetLength_OnGetCallCompatibility(Proc: TResElDataBuiltInProc;
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
       Expr: TPasExpr; RaiseOnError: boolean): integer; virtual;
     procedure BI_SetLength_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
     procedure BI_SetLength_OnFinishParamsExpr(Proc: TResElDataBuiltInProc;
@@ -1208,6 +1215,7 @@ type
     function AddBuiltInProc(const aName: string; Signature: string;
     function AddBuiltInProc(const aName: string; Signature: string;
       const GetCallCompatibility: TOnGetCallCompatibility;
       const GetCallCompatibility: TOnGetCallCompatibility;
       const GetCallResult: TOnGetCallResult;
       const GetCallResult: TOnGetCallResult;
+      const EvalConst: TOnEvalBIFunction = nil;
       const FinishParamsExpr: TOnFinishParamsExpr = nil;
       const FinishParamsExpr: TOnFinishParamsExpr = nil;
       const BuiltIn: TResolverBuiltInProc = bfCustom;
       const BuiltIn: TResolverBuiltInProc = bfCustom;
       const Flags: TBuiltInProcFlags = []): TResElDataBuiltInProc;
       const Flags: TBuiltInProcFlags = []): TResElDataBuiltInProc;
@@ -1304,6 +1312,7 @@ type
       ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
       ErrorOnFalse: boolean; ErrorEl: TPasElement): boolean;
     function CheckAssignCompatibility(const LHS, RHS: TPasElement;
     function CheckAssignCompatibility(const LHS, RHS: TPasElement;
       RaiseOnIncompatible: boolean = true): integer;
       RaiseOnIncompatible: boolean = true): integer;
+    procedure CheckAssignExprRange(const LeftResolved: TPasResolverResult; RHS: TPasExpr);
     function CheckAssignResCompatibility(const LHS, RHS: TPasResolverResult;
     function CheckAssignResCompatibility(const LHS, RHS: TPasResolverResult;
       ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
       ErrorEl: TPasElement; RaiseOnIncompatible: boolean): integer;
     function CheckEqualElCompatibility(Left, Right: TPasElement;
     function CheckEqualElCompatibility(Left, Right: TPasElement;
@@ -3359,6 +3368,7 @@ end;
 
 
 procedure TPasResolver.FinishConstRangeExpr(Left, Right: TPasExpr; out LeftResolved,
 procedure TPasResolver.FinishConstRangeExpr(Left, Right: TPasExpr; out LeftResolved,
   RightResolved: TPasResolverResult);
   RightResolved: TPasResolverResult);
+// for example Left..Right
 {$IFDEF EnablePasResRangeCheck}
 {$IFDEF EnablePasResRangeCheck}
 var
 var
   RgValue: TResEvalValue;
   RgValue: TResEvalValue;
@@ -3427,7 +3437,9 @@ procedure TPasResolver.FinishConstDef(El: TPasConst);
 begin
 begin
   ResolveExpr(El.Expr,rraRead);
   ResolveExpr(El.Expr,rraRead);
   if El.VarType<>nil then
   if El.VarType<>nil then
-    CheckAssignCompatibility(El,El.Expr,true);
+    CheckAssignCompatibility(El,El.Expr,true)
+  else
+    Eval(El.Expr,[refConst]);
 end;
 end;
 
 
 procedure TPasResolver.FinishProcedure(aProc: TPasProcedure);
 procedure TPasResolver.FinishProcedure(aProc: TPasProcedure);
@@ -4775,7 +4787,12 @@ begin
 
 
   case El.Kind of
   case El.Kind of
   akDefault:
   akDefault:
+    begin
     CheckAssignResCompatibility(LeftResolved,RightResolved,El.right,true);
     CheckAssignResCompatibility(LeftResolved,RightResolved,El.right,true);
+    {$IFDEF EnablePasResRangeCheck}
+    CheckAssignExprRange(LeftResolved,El.right);
+    {$ENDIF}
+    end;
   akAdd, akMinus,akMul,akDivision:
   akAdd, akMinus,akMul,akDivision:
     begin
     begin
     if (El.Kind in [akAdd,akMinus,akMul]) and (LeftResolved.BaseType in btAllInteger) then
     if (El.Kind in [akAdd,akMinus,akMul]) and (LeftResolved.BaseType in btAllInteger) then
@@ -4816,6 +4833,8 @@ begin
       end
       end
     else
     else
       RaiseMsg(20170216152125,nIllegalQualifier,sIllegalQualifier,[AssignKindNames[El.Kind]],El);
       RaiseMsg(20170216152125,nIllegalQualifier,sIllegalQualifier,[AssignKindNames[El.Kind]],El);
+    // store const expression result
+    Eval(El.right,[]);
     end;
     end;
   else
   else
     RaiseNotYetImplemented(20160927143649,El,'AssignKind '+AssignKindNames[El.Kind]);
     RaiseNotYetImplemented(20160927143649,El,'AssignKind '+AssignKindNames[El.Kind]);
@@ -6167,6 +6186,8 @@ begin
               if not (RightResolved.BaseType in btAllInteger) then
               if not (RightResolved.BaseType in btAllInteger) then
                 RaiseXExpectedButYFound(20170216152600,'integer',BaseTypeNames[RightResolved.BaseType],Bin.right);
                 RaiseXExpectedButYFound(20170216152600,'integer',BaseTypeNames[RightResolved.BaseType],Bin.right);
               SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
               SetResolverValueExpr(ResolvedEl,LeftResolved.BaseType,LeftResolved.TypeEl,Bin,[rrfReadable]);
+              if Bin.Parent is TPasRangeType then
+                ResolvedEl.TypeEl:=TPasRangeType(Bin.Parent);
               exit;
               exit;
               end;
               end;
           eopAdd, eopSubtract,
           eopAdd, eopSubtract,
@@ -7407,6 +7428,9 @@ function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags;
 // Important: Caller must free result if (Result<>nil) and (Result.Element=nil)
 // Important: Caller must free result if (Result<>nil) and (Result.Element=nil)
 //            use utility function ReleaseEvalValue(Result)
 //            use utility function ReleaseEvalValue(Result)
 begin
 begin
+  {$IFNDEF EnablePasResRangeCheck}
+  exit(nil);
+  {$ENDIF}
   Result:=fExprEvaluator.Eval(Expr,Flags);
   Result:=fExprEvaluator.Eval(Expr,Flags);
   if Result=nil then exit;
   if Result=nil then exit;
 
 
@@ -7482,6 +7506,28 @@ begin
     FBaseTypes[BaseTypeLength],[rrfReadable]);
     FBaseTypes[BaseTypeLength],[rrfReadable]);
 end;
 end;
 
 
+procedure TPasResolver.BI_Length_OnEval(Proc: TResElDataBuiltInProc;
+  Params: TParamsExpr; out Evaluated: TResEvalValue);
+var
+  Value: TResEvalValue;
+begin
+  Evaluated:=nil;
+  Value:=Eval(Params.Params[0],[refAutoConst]);
+  if Value=nil then exit;
+  if Value.Kind=revkString then
+    begin
+    Evaluated:=TResEvalInt.Create;
+    TResEvalInt(Evaluated).Int:=length(TResEvalString(Value).S);
+    end
+  else if Value.Kind=revkUnicodeString then
+    begin
+    Evaluated:=TResEvalInt.Create;
+    TResEvalInt(Evaluated).Int:=length(TResEvalUTF16(Value).S);
+    end;
+  ReleaseEvalValue(Value);
+  if Proc=nil then ;
+end;
+
 function TPasResolver.BI_SetLength_OnGetCallCompatibility(
 function TPasResolver.BI_SetLength_OnGetCallCompatibility(
   Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
   Proc: TResElDataBuiltInProc; Expr: TPasExpr; RaiseOnError: boolean): integer;
 // check params of built in proc 'setlength'
 // check params of built in proc 'setlength'
@@ -7985,7 +8031,7 @@ function TPasResolver.BI_Str_CheckParam(IsFunc: boolean; Param: TPasExpr;
       // floats supports value:Width:Precision
       // floats supports value:Width:Precision
       Ok:=true
       Ok:=true
     else
     else
-      // all other only support only Width
+      // all other only support value:Width
       Ok:=Index<2;
       Ok:=Index<2;
     if not Ok then
     if not Ok then
       begin
       begin
@@ -9109,82 +9155,91 @@ begin
     AddBaseType(BaseTypeNames[bt],bt);
     AddBaseType(BaseTypeNames[bt],bt);
   if bfLength in TheBaseProcs then
   if bfLength in TheBaseProcs then
     AddBuiltInProc('Length','function Length(const String or Array): sizeint',
     AddBuiltInProc('Length','function Length(const String or Array): sizeint',
-        @BI_Length_OnGetCallCompatibility,@BI_Length_OnGetCallResult,nil,bfLength);
+        @BI_Length_OnGetCallCompatibility,@BI_Length_OnGetCallResult,
+        @BI_Length_OnEval,nil,bfLength);
   if bfSetLength in TheBaseProcs then
   if bfSetLength in TheBaseProcs then
     AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)',
     AddBuiltInProc('SetLength','procedure SetLength(var String or Array; NewLength: sizeint)',
-        @BI_SetLength_OnGetCallCompatibility,nil,
+        @BI_SetLength_OnGetCallCompatibility,nil,nil,
         @BI_SetLength_OnFinishParamsExpr,bfSetLength,[bipfCanBeStatement]);
         @BI_SetLength_OnFinishParamsExpr,bfSetLength,[bipfCanBeStatement]);
   if bfInclude in TheBaseProcs then
   if bfInclude in TheBaseProcs then
     AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)',
     AddBuiltInProc('Include','procedure Include(var Set of Enum; const Enum)',
-        @BI_InExclude_OnGetCallCompatibility,nil,
+        @BI_InExclude_OnGetCallCompatibility,nil,nil,
         @BI_InExclude_OnFinishParamsExpr,bfInclude,[bipfCanBeStatement]);
         @BI_InExclude_OnFinishParamsExpr,bfInclude,[bipfCanBeStatement]);
   if bfExclude in TheBaseProcs then
   if bfExclude in TheBaseProcs then
     AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)',
     AddBuiltInProc('Exclude','procedure Exclude(var Set of Enum; const Enum)',
-        @BI_InExclude_OnGetCallCompatibility,nil,
+        @BI_InExclude_OnGetCallCompatibility,nil,nil,
         @BI_InExclude_OnFinishParamsExpr,bfExclude,[bipfCanBeStatement]);
         @BI_InExclude_OnFinishParamsExpr,bfExclude,[bipfCanBeStatement]);
   if bfBreak in TheBaseProcs then
   if bfBreak in TheBaseProcs then
     AddBuiltInProc('Break','procedure Break',
     AddBuiltInProc('Break','procedure Break',
-        @BI_Break_OnGetCallCompatibility,nil,nil,bfBreak,[bipfCanBeStatement]);
+        @BI_Break_OnGetCallCompatibility,nil,nil,nil,bfBreak,[bipfCanBeStatement]);
   if bfContinue in TheBaseProcs then
   if bfContinue in TheBaseProcs then
     AddBuiltInProc('Continue','procedure Continue',
     AddBuiltInProc('Continue','procedure Continue',
-        @BI_Continue_OnGetCallCompatibility,nil,nil,bfContinue,[bipfCanBeStatement]);
+        @BI_Continue_OnGetCallCompatibility,nil,nil,nil,bfContinue,[bipfCanBeStatement]);
   if bfExit in TheBaseProcs then
   if bfExit in TheBaseProcs then
     AddBuiltInProc('Exit','procedure Exit(result)',
     AddBuiltInProc('Exit','procedure Exit(result)',
-        @BI_Exit_OnGetCallCompatibility,nil,nil,bfExit,[bipfCanBeStatement]);
+        @BI_Exit_OnGetCallCompatibility,nil,nil,nil,bfExit,[bipfCanBeStatement]);
   if bfInc in TheBaseProcs then
   if bfInc in TheBaseProcs then
     AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)',
     AddBuiltInProc('Inc','procedure Inc(var Integer; const Incr: Integer = 1)',
-        @BI_IncDec_OnGetCallCompatibility,nil,
+        @BI_IncDec_OnGetCallCompatibility,nil,nil,
         @BI_IncDec_OnFinishParamsExpr,bfInc,[bipfCanBeStatement]);
         @BI_IncDec_OnFinishParamsExpr,bfInc,[bipfCanBeStatement]);
   if bfDec in TheBaseProcs then
   if bfDec in TheBaseProcs then
     AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)',
     AddBuiltInProc('Dec','procedure Dec(var Integer; const Decr: Integer = 1)',
-        @BI_IncDec_OnGetCallCompatibility,nil,
+        @BI_IncDec_OnGetCallCompatibility,nil,nil,
         @BI_IncDec_OnFinishParamsExpr,bfDec,[bipfCanBeStatement]);
         @BI_IncDec_OnFinishParamsExpr,bfDec,[bipfCanBeStatement]);
   if bfAssigned in TheBaseProcs then
   if bfAssigned in TheBaseProcs then
     AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean',
     AddBuiltInProc('Assigned','function Assigned(const Pointer or Class or Class-of): boolean',
-        @BI_Assigned_OnGetCallCompatibility,@BI_Assigned_OnGetCallResult,nil,bfAssigned);
+        @BI_Assigned_OnGetCallCompatibility,@BI_Assigned_OnGetCallResult,
+        nil,nil,bfAssigned);
   if bfChr in TheBaseProcs then
   if bfChr in TheBaseProcs then
     AddBuiltInProc('Chr','function Chr(const Integer): char',
     AddBuiltInProc('Chr','function Chr(const Integer): char',
-        @BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,nil,bfChr);
+        @BI_Chr_OnGetCallCompatibility,@BI_Chr_OnGetCallResult,nil,nil,bfChr);
   if bfOrd in TheBaseProcs then
   if bfOrd in TheBaseProcs then
     AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
     AddBuiltInProc('Ord','function Ord(const Enum or Char): integer',
-        @BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,nil,bfOrd);
+        @BI_Ord_OnGetCallCompatibility,@BI_Ord_OnGetCallResult,nil,nil,bfOrd);
   if bfLow in TheBaseProcs then
   if bfLow in TheBaseProcs then
     AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
     AddBuiltInProc('Low','function Low(const array or ordinal): ordinal or integer',
-        @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,nil,bfLow);
+        @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
+        nil,nil,bfLow);
   if bfHigh in TheBaseProcs then
   if bfHigh in TheBaseProcs then
     AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer',
     AddBuiltInProc('High','function High(const array or ordinal): ordinal or integer',
-        @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,nil,bfHigh);
+        @BI_LowHigh_OnGetCallCompatibility,@BI_LowHigh_OnGetCallResult,
+        nil,nil,bfHigh);
   if bfPred in TheBaseProcs then
   if bfPred in TheBaseProcs then
     AddBuiltInProc('Pred','function Pred(const ordinal): ordinal',
     AddBuiltInProc('Pred','function Pred(const ordinal): ordinal',
-        @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,nil,bfPred);
+        @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
+        nil,nil,bfPred);
   if bfSucc in TheBaseProcs then
   if bfSucc in TheBaseProcs then
     AddBuiltInProc('Succ','function Succ(const ordinal): ordinal',
     AddBuiltInProc('Succ','function Succ(const ordinal): ordinal',
-        @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,nil,bfSucc);
+        @BI_PredSucc_OnGetCallCompatibility,@BI_PredSucc_OnGetCallResult,
+        nil,nil,bfSucc);
   if bfStrProc in TheBaseProcs then
   if bfStrProc in TheBaseProcs then
     AddBuiltInProc('Str','procedure Str(const var; var String)',
     AddBuiltInProc('Str','procedure Str(const var; var String)',
-        @BI_StrProc_OnGetCallCompatibility,nil,
+        @BI_StrProc_OnGetCallCompatibility,nil,nil,
         @BI_StrProc_OnFinishParamsExpr,bfStrProc,[bipfCanBeStatement]);
         @BI_StrProc_OnFinishParamsExpr,bfStrProc,[bipfCanBeStatement]);
   if bfStrFunc in TheBaseProcs then
   if bfStrFunc in TheBaseProcs then
     AddBuiltInProc('Str','function Str(const var): String',
     AddBuiltInProc('Str','function Str(const var): String',
-        @BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,nil,bfStrFunc);
+        @BI_StrFunc_OnGetCallCompatibility,@BI_StrFunc_OnGetCallResult,
+        nil,nil,bfStrFunc);
   if bfConcatArray in TheBaseProcs then
   if bfConcatArray in TheBaseProcs then
     AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array',
     AddBuiltInProc('Concat','function Concat(const Array1, Array2, ...): Array',
-        @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,nil,bfConcatArray);
+        @BI_ConcatArray_OnGetCallCompatibility,@BI_ConcatArray_OnGetCallResult,
+        nil,nil,bfConcatArray);
   if bfCopyArray in TheBaseProcs then
   if bfCopyArray in TheBaseProcs then
     AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array',
     AddBuiltInProc('Copy','function Copy(const Array; Start: integer = 0; Count: integer = all): Array',
-        @BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,nil,bfCopyArray);
+        @BI_CopyArray_OnGetCallCompatibility,@BI_CopyArray_OnGetCallResult,
+        nil,nil,bfCopyArray);
   if bfInsertArray in TheBaseProcs then
   if bfInsertArray in TheBaseProcs then
     AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)',
     AddBuiltInProc('Insert','procedure Insert(const Element; var Array; Index: integer)',
-        @BI_InsertArray_OnGetCallCompatibility,nil,
+        @BI_InsertArray_OnGetCallCompatibility,nil,nil,
         @BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]);
         @BI_InsertArray_OnFinishParamsExpr,bfInsertArray,[bipfCanBeStatement]);
   if bfDeleteArray in TheBaseProcs then
   if bfDeleteArray in TheBaseProcs then
     AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)',
     AddBuiltInProc('Delete','procedure Delete(var Array; Start, Count: integer)',
-        @BI_DeleteArray_OnGetCallCompatibility,nil,
+        @BI_DeleteArray_OnGetCallCompatibility,nil,nil,
         @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]);
         @BI_DeleteArray_OnFinishParamsExpr,bfDeleteArray,[bipfCanBeStatement]);
   if bfTypeInfo in TheBaseProcs then
   if bfTypeInfo in TheBaseProcs then
     AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
     AddBuiltInProc('TypeInfo','function TypeInfo(type or var identifier): Pointer',
         @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
         @BI_TypeInfo_OnGetCallCompatibility,@BI_TypeInfo_OnGetCallResult,
-        nil,bfTypeInfo);
+        nil,nil,bfTypeInfo);
 end;
 end;
 
 
 function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
 function TPasResolver.AddBaseType(const aName: string; Typ: TResolverBaseType
@@ -9226,7 +9281,7 @@ end;
 
 
 function TPasResolver.AddBuiltInProc(const aName: string; Signature: string;
 function TPasResolver.AddBuiltInProc(const aName: string; Signature: string;
   const GetCallCompatibility: TOnGetCallCompatibility;
   const GetCallCompatibility: TOnGetCallCompatibility;
-  const GetCallResult: TOnGetCallResult;
+  const GetCallResult: TOnGetCallResult; const EvalConst: TOnEvalBIFunction;
   const FinishParamsExpr: TOnFinishParamsExpr;
   const FinishParamsExpr: TOnFinishParamsExpr;
   const BuiltIn: TResolverBuiltInProc; const Flags: TBuiltInProcFlags
   const BuiltIn: TResolverBuiltInProc; const Flags: TBuiltInProcFlags
   ): TResElDataBuiltInProc;
   ): TResElDataBuiltInProc;
@@ -9240,6 +9295,7 @@ begin
   Result.BuiltIn:=BuiltIn;
   Result.BuiltIn:=BuiltIn;
   Result.GetCallCompatibility:=GetCallCompatibility;
   Result.GetCallCompatibility:=GetCallCompatibility;
   Result.GetCallResult:=GetCallResult;
   Result.GetCallResult:=GetCallResult;
+  Result.Eval:=EvalConst;
   Result.FinishParamsExpression:=FinishParamsExpr;
   Result.FinishParamsExpression:=FinishParamsExpr;
   Result.Flags:=Flags;
   Result.Flags:=Flags;
   AddResolveData(El,Result,lkBuiltIn);
   AddResolveData(El,Result,lkBuiltIn);
@@ -10162,6 +10218,74 @@ begin
       Include(Flags,rcNoImplicitProcType);
       Include(Flags,rcNoImplicitProcType);
   ComputeElement(RHS,RightResolved,Flags);
   ComputeElement(RHS,RightResolved,Flags);
   Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,RHS,RaiseOnIncompatible);
   Result:=CheckAssignResCompatibility(LeftResolved,RightResolved,RHS,RaiseOnIncompatible);
+  if RHS is TPasExpr then
+    begin
+    {$IFDEF EnablePasResRangeCheck}
+    CheckAssignExprRange(LeftResolved,TPasExpr(RHS));
+    {$ENDIF}
+    end;
+end;
+
+procedure TPasResolver.CheckAssignExprRange(
+  const LeftResolved: TPasResolverResult; RHS: TPasExpr);
+var
+  RValue: TResEvalValue;
+  MinVal, MaxVal: int64;
+  RgExpr: TBinaryExpr;
+begin
+  RValue:=Eval(RHS,[refAutoConst]);
+  if RValue=nil then
+    exit; // not a const expression
+  {$IFDEF VerbosePasResEval}
+  writeln('TPasResolver.CheckAssignExprRange ',RValue.AsDebugString);
+  {$ENDIF}
+  try
+    if LeftResolved.TypeEl is TPasRangeType then
+      begin
+      RgExpr:=TPasRangeType(LeftResolved.TypeEl).RangeExpr;
+      fExprEvaluator.IsInRange(RHS,RgExpr,true);
+      end
+    else if (LeftResolved.BaseType in (btAllInteger-[btQWord]))
+        and GetIntegerRange(LeftResolved.BaseType,MinVal,MaxVal) then
+      case RValue.Kind of
+      revkInt:
+        if (MinVal>TResEvalInt(RValue).Int)
+            or (MaxVal<TResEvalInt(RValue).Int) then
+          fExprEvaluator.EmitRangeCheckConst(20170530093126,
+            IntToStr(TResEvalInt(RValue).Int),MinVal,MaxVal,RHS);
+      revkUInt:
+        if (TResEvalUInt(RValue).UInt>High(MaxPrecInt))
+            or (MinVal>MaxPrecInt(TResEvalUInt(RValue).UInt))
+            or (MaxVal<MaxPrecInt(TResEvalUInt(RValue).UInt)) then
+          fExprEvaluator.EmitRangeCheckConst(20170530093616,
+            IntToStr(TResEvalUInt(RValue).UInt),IntToStr(MinVal),IntToStr(MaxVal),RHS);
+      else
+        RaiseNotYetImplemented(20170530092731,RHS);
+      end
+    else if LeftResolved.BaseType=btQWord then
+      case RValue.Kind of
+      revkInt:
+        if (TResEvalInt(RValue).Int<0) then
+          fExprEvaluator.EmitRangeCheckConst(20170530094316,
+            IntToStr(TResEvalUInt(RValue).UInt),'0',IntToStr(High(QWord)),RHS);
+      revkUInt: ;
+      else
+        RaiseNotYetImplemented(20170530094311,RHS);
+      end
+    else if RValue.Kind=revkNil then
+      // simple type check is enough
+    else if RValue.Kind=revkBool then
+      // simple type check is enough
+    else
+      begin
+      {$IFDEF VerbosePasResolver}
+      writeln('TPasResolver.CheckAssignExprRange LeftResolved=',GetResolverResultDbg(LeftResolved));
+      {$ENDIF}
+      RaiseNotYetImplemented(20170530095243,RHS);
+      end;
+  finally
+    ReleaseEvalValue(RValue);
+  end;
 end;
 end;
 
 
 function TPasResolver.CheckAssignResCompatibility(const LHS,
 function TPasResolver.CheckAssignResCompatibility(const LHS,

+ 65 - 6
packages/fcl-passrc/tests/tcresolver.pas

@@ -186,7 +186,11 @@ type
     Procedure TestVarNoSemicolonBeginFail;
     Procedure TestVarNoSemicolonBeginFail;
     Procedure TestIntegerRange;
     Procedure TestIntegerRange;
     Procedure TestIntegerRangeHighLowerLowFail;
     Procedure TestIntegerRangeHighLowerLowFail;
-    Procedure TestAssignIntRangeFail; // ToDo
+    Procedure TestAssignIntRangeFail;
+    Procedure TestByteRangeFail;
+    Procedure TestCustomIntRangeFail;
+    Procedure TestConstIntOperators;
+    //Procedure TestConstBoolOperators; ToDo
 
 
     // strings
     // strings
     Procedure TestChar_Ord;
     Procedure TestChar_Ord;
@@ -198,6 +202,7 @@ type
     Procedure TestStringElement_AsVarArgFail;
     Procedure TestStringElement_AsVarArgFail;
     Procedure TestString_DoubleQuotesFail;
     Procedure TestString_DoubleQuotesFail;
     Procedure TestString_ShortstringType;
     Procedure TestString_ShortstringType;
+    //Procedure TestConstStringOperators; ToDo
 
 
     // enums
     // enums
     Procedure TestEnums;
     Procedure TestEnums;
@@ -1156,7 +1161,7 @@ begin
   for i:=0 to MsgCount-1 do
   for i:=0 to MsgCount-1 do
     begin
     begin
     Item:=Msgs[i];
     Item:=Msgs[i];
-    writeln('TCustomTestResolver.CheckResolverHint ',Item.MsgType,' ('+IntToStr(Item.MsgNumber),') {',Item.Msg,'}');
+    writeln('TCustomTestResolver.CheckResolverHint ',i,'/',MsgCount,' ',Item.MsgType,' ('+IntToStr(Item.MsgNumber),') {',Item.Msg,'}');
     end;
     end;
   str(MsgType,Expected);
   str(MsgType,Expected);
   Fail('Missing '+Expected+' ('+IntToStr(MsgNumber)+') '+Msg);
   Fail('Missing '+Expected+' ('+IntToStr(MsgNumber)+') '+Msg);
@@ -2148,20 +2153,74 @@ end;
 
 
 procedure TTestResolver.TestAssignIntRangeFail;
 procedure TTestResolver.TestAssignIntRangeFail;
 begin
 begin
-  // ToDo
   StartProgram(false);
   StartProgram(false);
   Add([
   Add([
   'type TMyInt = 1..2;',
   'type TMyInt = 1..2;',
   'var i: TMyInt;',
   'var i: TMyInt;',
   'begin',
   'begin',
   '  i:=3;']);
   '  i:=3;']);
-  exit;
+  ParseProgram;
   {$IFDEF EnablePasResRangeCheck}
   {$IFDEF EnablePasResRangeCheck}
-  CheckResolverException(sHighRangeLimitLTLowRangeLimit,
-    nHighRangeLimitLTLowRangeLimit);
+  CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
+    'range check error while evaluating constants (3 must be between 1 and 2)');
+  CheckResolverUnexpectedHints;
   {$ENDIF}
   {$ENDIF}
 end;
 end;
 
 
+procedure TTestResolver.TestByteRangeFail;
+begin
+  StartProgram(false);
+  Add([
+  'var b:byte=300;',
+  'begin']);
+  ParseProgram;
+  {$IFDEF EnablePasResRangeCheck}
+  CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
+    'range check error while evaluating constants (300 must be between 0 and 255)');
+  CheckResolverUnexpectedHints;
+  {$ENDIF}
+end;
+
+procedure TTestResolver.TestCustomIntRangeFail;
+begin
+  StartProgram(false);
+  Add([
+  'const i:1..2 = 3;',
+  'begin']);
+  ParseProgram;
+  {$IFDEF EnablePasResRangeCheck}
+  CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
+    'range check error while evaluating constants (3 must be between 1 and 2)');
+  CheckResolverUnexpectedHints;
+  {$ENDIF}
+end;
+
+procedure TTestResolver.TestConstIntOperators;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  a:byte=1+2;',
+  '  b:shortint=1-2;',
+  '  c:word=2*3;',
+  '  d:smallint=5 div 2;',
+  '  e:longword=5 mod 2;',
+  '  f:longint=5 shl 2;',
+  '  g:qword=5 shr 2;',
+  '  h:boolean=5=2;',
+  '  i:boolean=5<>2;',
+  //'  j:boolean=5<2;',
+  //'  k:boolean=5>2;',
+  //'  l:boolean=5<=2;',
+  //'  m:boolean=5>=2;',
+  //'  n:longword=5 and 2;',
+  //'  o:longword=5 or 2;',
+  //'  p:longword=5 xor 2;',
+  //'  q:longword=5 or not 2;',
+  'begin']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestChar_Ord;
 procedure TTestResolver.TestChar_Ord;
 begin
 begin
   StartProgram(false);
   StartProgram(false);

Some files were not shown because too many files changed in this diff