fcl-passrc: resolver: range check on: warnings becomes errors

git-svn-id: trunk@38828 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -235,7 +235,7 @@ resourcestring
   sSymbolXIsDeprecatedY = 'Symbol "%s" is deprecated: %s';
   sRangeCheckError = 'Range check error';
   sHighRangeLimitLTLowRangeLimit = 'High range limit < low range limit';
-  sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s must be between %s and %s)';
+  sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s is not between %s and %s)';
   sIllegalChar = 'Illegal character';
   sOverflowInArithmeticOperation = 'Overflow in arithmetic operation';
   sDivByZero = 'Division by zero';
@@ -552,6 +552,8 @@ type
     Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue of object;
   TPasResEvalParamsHandler = function(Sender: TResExprEvaluator;
     Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue of object;
+  TPasResEvalRangeCheckElHandler = procedure(Sender: TResExprEvaluator;
+    El: TPasElement; var MsgType: TMessageType) of object;
 
   { TResExprEvaluator }
 
@@ -562,6 +564,7 @@ type
     FOnEvalIdentifier: TPasResEvalIdentHandler;
     FOnEvalParams: TPasResEvalParamsHandler;
     FOnLog: TPasResEvalLogHandler;
+    FOnRangeCheckEl: TPasResEvalRangeCheckElHandler;
   protected
     procedure LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer;
       const Fmt: String; Args: Array of const; PosEl: TPasElement); overload;
@@ -638,6 +641,7 @@ type
     property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog;
     property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier;
     property OnEvalParams: TPasResEvalParamsHandler read FOnEvalParams write FOnEvalParams;
+    property OnRangeCheckEl: TPasResEvalRangeCheckElHandler read FOnRangeCheckEl write FOnRangeCheckEl;
     property AllowedInts: TResEvalTypedInts read FAllowedInts write FAllowedInts;
     property DefaultStringCodePage: TSystemCodePage read FDefaultEncoding write FDefaultEncoding;
   end;
@@ -4352,6 +4356,8 @@ end;
 procedure TResExprEvaluator.EmitRangeCheckConst(id: int64; const aValue,
   MinVal, MaxVal: String; PosEl: TPasElement; MsgType: TMessageType);
 begin
+  if Assigned(OnRangeCheckEl) then
+    OnRangeCheckEl(Self,PosEl,MsgType);
   LogMsg(id,MsgType,nRangeCheckEvaluatingConstantsVMinMax,
     sRangeCheckEvaluatingConstantsVMinMax,[aValue,MinVal,MaxVal],PosEl);
 end;

packages/fcl-passrc/src/pasresolver.pp

@@ -1359,6 +1359,8 @@ type
       Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
     function OnExprEvalParams(Sender: TResExprEvaluator;
       Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
+    procedure OnRangeCheckEl(Sender: TResExprEvaluator; El: TPasElement;
+      var MsgType: TMessageType); virtual;
     function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
   protected
     // custom types (added by descendant resolvers)
@@ -10504,6 +10506,15 @@ begin
   if Flags=[] then ;
 end;
 
+procedure TPasResolver.OnRangeCheckEl(Sender: TResExprEvaluator;
+  El: TPasElement; var MsgType: TMessageType);
+begin
+  if El=nil then exit;
+  if (MsgType=mtWarning)
+      and (bsRangeChecks in CurrentParser.Scanner.CurrentBoolSwitches) then
+    MsgType:=mtError;
+end;
+
 function TPasResolver.EvalBaseTypeCast(Params: TParamsExpr;
   bt: TResolverBaseType): TResEvalvalue;
 
@@ -12158,6 +12169,7 @@ begin
   fExprEvaluator.OnLog:=@OnExprEvalLog;
   fExprEvaluator.OnEvalIdentifier:=@OnExprEvalIdentifier;
   fExprEvaluator.OnEvalParams:=@OnExprEvalParams;
+  fExprEvaluator.OnRangeCheckEl:=@OnRangeCheckEl;
   PushScope(FDefaultScope);
 end;
 

packages/fcl-passrc/tests/tcresolver.pas

@@ -686,6 +686,7 @@ type
 
     // static arrays
     Procedure TestArrayIntRange_OutOfRange;
+    Procedure TestArrayIntRange_OutOfRangeError;
     Procedure TestArrayCharRange_OutOfRange;
 
     // procedure types
@@ -2813,7 +2814,7 @@ begin
   '  i:=3;']);
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (3 must be between 1 and 2)');
+    'range check error while evaluating constants (3 is not between 1 and 2)');
   CheckResolverUnexpectedHints;
 end;
 
@@ -2825,7 +2826,7 @@ begin
   'begin']);
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (300 must be between 0 and 255)');
+    'range check error while evaluating constants (300 is not between 0 and 255)');
   CheckResolverUnexpectedHints;
 end;
 
@@ -2848,7 +2849,7 @@ begin
   'begin']);
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (3 must be between 1 and 2)');
+    'range check error while evaluating constants (3 is not between 1 and 2)');
   CheckResolverUnexpectedHints;
 end;
 
@@ -11020,7 +11021,7 @@ begin
   Add('begin');
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (300 must be between -128 and 127)');
+    'range check error while evaluating constants (300 is not between -128 and 127)');
 end;
 
 procedure TTestResolver.TestArrayOfArray;
@@ -11669,10 +11670,24 @@ begin
   '']);
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (0 must be between 1 and 2)');
+    'range check error while evaluating constants (0 is not between 1 and 2)');
   CheckResolverUnexpectedHints;
 end;
 
+procedure TTestResolver.TestArrayIntRange_OutOfRangeError;
+begin
+  StartProgram(false);
+  Add([
+  '{$R+}',
+  'type TArr = array[1..2] of longint;',
+  'var a: TArr;',
+  'begin',
+  '  a[0]:=3;',
+  '']);
+  CheckResolverException('range check error while evaluating constants (0 is not between 1 and 2)',
+    nRangeCheckEvaluatingConstantsVMinMax);
+end;
+
 procedure TTestResolver.TestArrayCharRange_OutOfRange;
 begin
   StartProgram(false);
@@ -11684,7 +11699,7 @@ begin
   '']);
   ParseProgram;
   CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax,
-    'range check error while evaluating constants (''0'' must be between ''a'' and ''b'')');
+    'range check error while evaluating constants (''0'' is not between ''a'' and ''b'')');
   CheckResolverUnexpectedHints;
 end;