fcl-passrc: resolver: check duplicate case labels

git-svn-id: trunk@38837 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -167,6 +167,7 @@ const
   nDoesNotImplementInterface = 3105;
   nTypeCycleFound = 3106;
   nTypeXIsNotYetCompletelyDefined = 3107;
+  nDuplicateCaseValueXatY = 3108;
 
 // resourcestring patterns of messages
 resourcestring
@@ -266,6 +267,7 @@ resourcestring
   sDoesNotImplementInterface = '"%s" does not implement interface "%s"';
   sTypeCycleFound = 'Type cycle found';
   sTypeXIsNotYetCompletelyDefined = 'type "%s" is not yet completely defined';
+  sDuplicateCaseValueXatY = 'Duplicate case value "%s", other at %s';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }
@@ -526,7 +528,8 @@ type
   public
     Ranges: TItems; // disjunct, sorted ascending
     constructor Create; override;
-    constructor CreateEmpty(aSet: TResEvalSet);
+    constructor CreateEmpty(const aElKind: TRESetElKind; aElType: TPasType = nil);
+    constructor CreateEmptySameKind(aSet: TResEvalSet);
     constructor CreateValue(const aElKind: TRESetElKind; aElType: TPasType;
       const aRangeStart, aRangeEnd: MaxPrecInt); override;
     function Clone: TResEvalValue; override;
@@ -1855,10 +1858,10 @@ begin
       LeftSet:=TResEvalSet(LeftValue);
       RightSet:=TResEvalSet(RightValue);
       if LeftSet.ElKind=revskNone then
-        Result:=TResEvalSet.CreateEmpty(RightSet)
+        Result:=TResEvalSet.CreateEmptySameKind(RightSet)
       else
         begin
-        Result:=TResEvalSet.CreateEmpty(LeftSet);
+        Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
         // add elements, which exists only in LeftSet
         for i:=0 to length(LeftSet.Ranges)-1 do
           begin
@@ -2137,10 +2140,10 @@ begin
       LeftSet:=TResEvalSet(LeftValue);
       RightSet:=TResEvalSet(RightValue);
       if LeftSet.ElKind=revskNone then
-        Result:=TResEvalSet.CreateEmpty(RightSet)
+        Result:=TResEvalSet.CreateEmptySameKind(RightSet)
       else
         begin
-        Result:=TResEvalSet.CreateEmpty(LeftSet);
+        Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
         // add elements, which exists in both
         for i:=0 to length(LeftSet.Ranges)-1 do
           begin
@@ -3262,7 +3265,7 @@ begin
         Result:=RightSet.Clone
       else
         begin
-        Result:=TResEvalSet.CreateEmpty(LeftSet);
+        Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
         for i:=0 to length(LeftSet.Ranges)-1 do
           begin
           Int:=LeftSet.Ranges[i].RangeStart;
@@ -5259,7 +5262,15 @@ begin
   Kind:=revkSetOfInt;
 end;
 
-constructor TResEvalSet.CreateEmpty(aSet: TResEvalSet);
+constructor TResEvalSet.CreateEmpty(const aElKind: TRESetElKind;
+  aElType: TPasType);
+begin
+  Create;
+  ElKind:=aElKind;
+  ElType:=aElType;
+end;
+
+constructor TResEvalSet.CreateEmptySameKind(aSet: TResEvalSet);
 begin
   Create;
   IdentEl:=aSet.IdentEl;

packages/fcl-passrc/src/pasresolver.pp

@@ -37,6 +37,7 @@ Works:
 - if..then..else
 - binary operators
 - case..of
+  - check duplicate values
 - try..finally..except, on, else, raise
 - for loop
 - spot duplicates
@@ -204,7 +205,6 @@ ToDo:
 - $RTTI inherited|explicit
 - range checking:
   - indexedprop[param]
-  - case-of unique
   - defaultvalue
 - fail to write a loop var inside the loop
 - nested classes
@@ -212,10 +212,10 @@ ToDo:
    - const  TRecordValues
    - function default(record type): record
    - pointer of record
+- dispose(pointerofrecord), new(pointerofrecord)
 - proc: check if forward and impl default values match
 - call array of proc without ()
 - array+array
-- pointer type, ^type, @ operator, [] operator
 - type alias type
 - set of CharRange
 - object
@@ -6544,6 +6544,200 @@ begin
 end;
 
 procedure TPasResolver.ResolveImplCaseOf(CaseOf: TPasImplCaseOf);
+type
+  TRangeItem = record
+    RangeStart, RangeEnd: MaxPrecInt;
+    Expr: TPasExpr;
+  end;
+  PRangeItem = ^TRangeItem;
+
+  function CreateValues(const ResolvedEl: TPasResolverResult;
+    var ValueSet: TResEvalSet; var ValueStrings: TStringList): boolean;
+  var
+    CaseExprType: TPasType;
+  begin
+    Result:=false;
+    if ResolvedEl.BaseType in btAllInteger then
+      begin
+      ValueSet:=TResEvalSet.CreateEmpty(revskInt);
+      Result:=true;
+      end
+    else if ResolvedEl.BaseType in btAllBooleans then
+      begin
+      ValueSet:=TResEvalSet.CreateEmpty(revskBool);
+      Result:=true;
+      end
+    else if ResolvedEl.BaseType in btAllChars then
+      begin
+      ValueSet:=TResEvalSet.CreateEmpty(revskChar);
+      Result:=true;
+      end
+    else if ResolvedEl.BaseType in btAllStrings then
+      begin
+      ValueStrings:=TStringList.Create;
+      Result:=true;
+      end
+    else if ResolvedEl.BaseType=btContext then
+      begin
+      CaseExprType:=ResolveAliasType(ResolvedEl.TypeEl);
+      if CaseExprType.ClassType=TPasEnumType then
+        begin
+        ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType);
+        Result:=true;
+        end;
+      end
+    else if ResolvedEl.BaseType=btRange then
+      begin
+      if ResolvedEl.SubType in btAllInteger then
+        begin
+        ValueSet:=TResEvalSet.CreateEmpty(revskInt);
+        Result:=true;
+        end
+      else if ResolvedEl.SubType in btAllBooleans then
+        begin
+        ValueSet:=TResEvalSet.CreateEmpty(revskBool);
+        Result:=true;
+        end
+      else if ResolvedEl.SubType in btAllChars then
+        begin
+        ValueSet:=TResEvalSet.CreateEmpty(revskChar);
+        Result:=true;
+        end
+      else if ResolvedEl.SubType=btContext then
+        begin
+        CaseExprType:=ResolveAliasType(ResolvedEl.TypeEl);
+        if CaseExprType.ClassType=TPasEnumType then
+          begin
+          ValueSet:=TResEvalSet.CreateEmpty(revskEnum,CaseExprType);
+          Result:=true;
+          end;
+        end;
+      end;
+
+  end;
+
+  function AddValue(Value: TResEvalValue; Values: TFPList; ValueSet: TResEvalSet;
+    ValueStrings: TStrings; Expr: TPasExpr): boolean;
+
+    procedure AddString(const s: string);
+    var
+      Dupl: TPasExpr;
+      i: Integer;
+    begin
+      if ValueStrings=nil then
+        RaiseNotYetImplemented(20180424215755,Expr,Value.AsDebugString);
+      for i:=0 to ValueStrings.Count-1 do
+        if ValueStrings[i]=s then
+          begin
+          Dupl:=TPasExpr(ValueStrings.Objects[i]);
+          RaiseMsg(20180424220139,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
+            ['string',GetElementSourcePosStr(Dupl)],Expr);
+          end;
+      ValueStrings.AddObject(s,Expr);
+    end;
+
+  var
+    RangeStart, RangeEnd: MaxPrecInt;
+    i: Integer;
+    Item: PRangeItem;
+  begin
+    {$IFDEF VerbosePasResolver}
+    //writeln('TPasResolver.ResolveImplCaseOf.AddValue Value={',Value.AsDebugString,'} Values.Count=',Values.Count);
+    {$ENDIF}
+    Result:=true;
+    case Value.Kind of
+    revkBool:
+      begin
+      RangeStart:=ord(TResEvalBool(Value).B);
+      RangeEnd:=RangeStart;
+      end;
+    revkInt:
+      begin
+      RangeStart:=TResEvalInt(Value).Int;
+      RangeEnd:=RangeStart;
+      end;
+    revkUInt:
+      begin
+      // Note: when FPC compares int64 with qword it converts the qword to an int64
+      if TResEvalUInt(Value).UInt>HighIntAsUInt then
+        ExprEvaluator.EmitRangeCheckConst(20180424212414,Value.AsString,
+          '0',IntToStr(High(MaxPrecInt)),Expr,mtError);
+      RangeStart:=TResEvalUInt(Value).UInt;
+      RangeEnd:=RangeStart;
+      end;
+    revkString:
+      if ValueStrings<>nil then
+        begin
+        AddString(TResEvalString(Value).S);
+        exit(true);
+        end
+      else
+        begin
+        if length(TResEvalString(Value).S)<>1 then
+          exit(false);
+        RangeStart:=ord(TResEvalString(Value).S[1]);
+        RangeEnd:=RangeStart;
+        end;
+    revkUnicodeString:
+      if ValueStrings<>nil then
+        begin
+        AddString(UTF8Encode(TResEvalUTF16(Value).S));
+        exit(true);
+        end
+      else
+        begin
+        if length(TResEvalUTF16(Value).S)<>1 then
+          exit(false);
+        RangeStart:=ord(TResEvalUTF16(Value).S[1]);
+        RangeEnd:=RangeStart;
+        end;
+    revkEnum:
+      begin
+      RangeStart:=TResEvalEnum(Value).Index;
+      RangeEnd:=RangeStart;
+      end;
+    revkRangeInt:
+      begin
+      RangeStart:=TResEvalRangeInt(Value).RangeStart;
+      RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
+      end;
+    revkRangeUInt:
+      begin
+      // Note: when FPC compares int64 with qword it converts the qword to an int64
+      if TResEvalRangeUInt(Value).RangeEnd>HighIntAsUInt then
+        ExprEvaluator.EmitRangeCheckConst(20180424212648,Value.AsString,
+          '0',IntToStr(High(MaxPrecInt)),Expr,mtError);
+      RangeStart:=TResEvalRangeUInt(Value).RangeStart;
+      RangeEnd:=TResEvalRangeUInt(Value).RangeEnd;
+      end;
+    else
+      Result:=false;
+    end;
+
+    if ValueSet=nil then
+      RaiseNotYetImplemented(20180424215728,Expr,Value.AsDebugString);
+    i:=ValueSet.Intersects(RangeStart,RangeEnd);
+    if i<0 then
+      begin
+      ValueSet.Add(RangeStart,RangeEnd);
+      New(Item);
+      Item^.RangeStart:=RangeStart;
+      Item^.RangeEnd:=RangeEnd;
+      Item^.Expr:=Expr;
+      Values.Add(Item);
+      exit(true);
+      end;
+    // duplicate value -> show where
+    for i:=0 to Values.Count-1 do
+      begin
+      Item:=PRangeItem(Values[i]);
+      if (Item^.RangeStart>RangeEnd) or (Item^.RangeEnd<RangeStart) then continue;
+      RaiseMsg(20180424214305,nDuplicateCaseValueXatY,sDuplicateCaseValueXatY,
+        [Value.AsString,GetElementSourcePosStr(Item^.Expr)],Expr);
+      end;
+    Result:=false;
+  end;
+
 var
   i, j: Integer;
   El: TPasElement;
@@ -6551,48 +6745,67 @@ var
   CaseExprResolved, OfExprResolved: TPasResolverResult;
   OfExpr: TPasExpr;
   ok: Boolean;
+  Values: TFPList; // list of PRangeItem
+  ValueSet: TResEvalSet;
+  ValueStrings: TStringList;
+  Value: TResEvalValue;
+  Item: PRangeItem;
 begin
   ResolveExpr(CaseOf.CaseExpr,rraRead);
   ComputeElement(CaseOf.CaseExpr,CaseExprResolved,[rcSetReferenceFlags]);
   ok:=false;
-  if (rrfReadable in CaseExprResolved.Flags) then
-    begin
-    if (CaseExprResolved.BaseType in (btAllInteger+btAllBooleans+btAllStringAndChars)) then
-      ok:=true
-    else if CaseExprResolved.BaseType=btContext then
-      begin
-      if CaseExprResolved.TypeEl.ClassType=TPasEnumType then
-        ok:=true;
-      end;
-    end;
-  if not ok then
-    RaiseXExpectedButYFound(20170216151952,'ordinal expression',
-               GetTypeDescription(CaseExprResolved.TypeEl),CaseOf.CaseExpr);
+  Values:=TFPList.Create;
+  ValueSet:=nil;
+  ValueStrings:=nil;
+  Value:=nil;
+  try
+    if (rrfReadable in CaseExprResolved.Flags) then
+      ok:=CreateValues(CaseExprResolved,ValueSet,ValueStrings);
+    if not ok then
+      RaiseXExpectedButYFound(20170216151952,'ordinal expression',
+                 GetTypeDescription(CaseExprResolved.TypeEl),CaseOf.CaseExpr);
 
-  for i:=0 to CaseOf.Elements.Count-1 do
-    begin
-    El:=TPasElement(CaseOf.Elements[i]);
-    if El.ClassType=TPasImplCaseStatement then
+    for i:=0 to CaseOf.Elements.Count-1 do
       begin
-      Stat:=TPasImplCaseStatement(El);
-      for j:=0 to Stat.Expressions.Count-1 do
+      El:=TPasElement(CaseOf.Elements[i]);
+      if El.ClassType=TPasImplCaseStatement then
         begin
-        //writeln('TPasResolver.ResolveImplCaseOf Stat.Expr[',j,']=',GetObjName(El));
-        OfExpr:=TPasExpr(Stat.Expressions[j]);
-        ResolveExpr(OfExpr,rraRead);
-        ComputeElement(OfExpr,OfExprResolved,[rcConstant,rcSetReferenceFlags]);
-        if OfExprResolved.BaseType=btRange then
-          ConvertRangeToElement(OfExprResolved);
-        CheckEqualResCompatibility(CaseExprResolved,OfExprResolved,OfExpr,true);
-        end;
-      ResolveImplElement(Stat.Body);
-      end
-    else if El.ClassType=TPasImplCaseElse then
-      ResolveImplBlock(TPasImplCaseElse(El))
-    else
-      RaiseNotYetImplemented(20160922163448,El);
-    end;
-  // Note: CaseOf.ElseBranch was already resolved via Elements
+        Stat:=TPasImplCaseStatement(El);
+        for j:=0 to Stat.Expressions.Count-1 do
+          begin
+          //writeln('TPasResolver.ResolveImplCaseOf Stat.Expr[',j,']=',GetObjName(El));
+          OfExpr:=TPasExpr(Stat.Expressions[j]);
+          ResolveExpr(OfExpr,rraRead);
+          ComputeElement(OfExpr,OfExprResolved,[rcConstant,rcSetReferenceFlags]);
+          if OfExprResolved.BaseType=btRange then
+            ConvertRangeToElement(OfExprResolved);
+          CheckEqualResCompatibility(CaseExprResolved,OfExprResolved,OfExpr,true);
+
+          Value:=Eval(OfExpr,[refConst]);
+          if Value<>nil then
+            if not AddValue(Value,Values,ValueSet,ValueStrings,OfExpr) then
+              RaiseIncompatibleTypeRes(20180424210815,nIncompatibleTypesGotExpected,
+                [],OfExprResolved,CaseExprResolved,OfExpr);
+          ReleaseEvalValue(Value);
+          end;
+        ResolveImplElement(Stat.Body);
+        end
+      else if El.ClassType=TPasImplCaseElse then
+        ResolveImplBlock(TPasImplCaseElse(El))
+      else
+        RaiseNotYetImplemented(20160922163448,El);
+      end;
+    // Note: CaseOf.ElseBranch was already resolved via Elements
+  finally
+    ReleaseEvalValue(Value);
+    ValueSet.Free;
+    ValueStrings.Free;
+    for i:=0 to Values.Count-1 do
+      begin
+      Item:=PRangeItem(Values[i]);
+      Dispose(Item);
+      end;
+  end;
 end;
 
 procedure TPasResolver.ResolveImplLabelMark(Mark: TPasImplLabelMark);
@@ -11528,9 +11741,9 @@ begin
       if length(aSet.Ranges)=0 then
         RaiseXExpectedButYFound(20170601201637,'ordinal value',Value.AsString,Param);
       if Proc.BuiltIn=bfLow then
-        Int:=aSet.Ranges[0].RangeStart
+        Int:=aSet.RangeStart
       else
-        Int:=aSet.Ranges[length(aSet.Ranges)-1].RangeEnd;
+        Int:=aSet.RangeEnd;
       case aSet.ElKind of
         revskEnum:
           begin

packages/fcl-passrc/tests/tcresolver.pas

@@ -311,6 +311,11 @@ type
     Procedure TestForLoop;
     Procedure TestStatements;
     Procedure TestCaseStatement;
+    Procedure TestCaseStatementDuplicateIntFail;
+    Procedure TestCaseStatementDuplicateStringFail;
+    Procedure TestCaseOf;
+    Procedure TestCaseExprNonOrdFail;
+    Procedure TestCaseIncompatibleValueFail;
     Procedure TestTryStatement;
     Procedure TestTryExceptOnNonTypeFail;
     Procedure TestTryExceptOnNonClassFail;
@@ -325,9 +330,6 @@ type
     Procedure TestForLoopVarNonVarFail;
     Procedure TestForLoopStartIncompFail;
     Procedure TestForLoopEndIncompFail;
-    Procedure TestCaseOf;
-    Procedure TestCaseExprNonOrdFail;
-    Procedure TestCaseIncompatibleValueFail;
     Procedure TestSimpleStatement_VarFail;
 
     // units
@@ -4455,22 +4457,116 @@ begin
   StartProgram(false);
   Add('const');
   Add('  {#c1}c1=1;');
-  Add('  {#c2}c2=1;');
+  Add('  {#c2}c2=2;');
+  Add('  {#c3}c3=3;');
+  Add('  {#c4}c4=4;');
+  Add('  {#c5}c5=5;');
+  Add('  {#c6}c6=6;');
   Add('var');
   Add('  {#v1}v1,{#v2}v2,{#v3}v3:longint;');
   Add('begin');
   Add('  Case {@v1}v1+{@v2}v2 of');
   Add('  {@c1}c1:');
   Add('    {@v2}v2:={@v3}v3;');
-  Add('  {@c1}c1,{@c2}c2: ;');
-  Add('  {@c1}c1..{@c2}c2: ;');
-  Add('  {@c1}c1+{@c2}c2: ;');
+  Add('  {@c2}c2,{@c3}c3: ;');
+  Add('  {@c4}c4..5: ;');
+  Add('  {@c5}c5+{@c6}c6: ;');
   Add('  else');
   Add('    {@v1}v1:=3;');
   Add('  end;');
   ParseProgram;
 end;
 
+procedure TTestResolver.TestCaseStatementDuplicateIntFail;
+begin
+  StartProgram(false);
+  Add([
+  'var i: longint;',
+  'begin',
+  '  case i of',
+  '  2: ;',
+  '  1..3: ;',
+  '  end;',
+  '']);
+  CheckResolverException('Duplicate case value "1..3", other at afile.pp(5,3)',nDuplicateCaseValueXatY);
+end;
+
+procedure TTestResolver.TestCaseStatementDuplicateStringFail;
+begin
+  StartProgram(false);
+  Add([
+  'var s: string;',
+  'begin',
+  '  case s of',
+  '  ''a''#10''bc'': ;',
+  '  ''A''#10''BC'': ;',
+  '  ''a''#10''bc'': ;',
+  '  end;',
+  '']);
+  CheckResolverException('Duplicate case value "string", other at afile.pp(5,3)',nDuplicateCaseValueXatY);
+end;
+
+procedure TTestResolver.TestCaseOf;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TFlag = (red,green,blue);');
+  Add('var');
+  Add('  i: longint;');
+  Add('  f: TFlag;');
+  Add('  b: boolean;');
+  Add('  c: char;');
+  Add('  s: string;');
+  Add('begin');
+  Add('  case i of');
+  Add('  1: ;');
+  Add('  2..3: ;');
+  Add('  4,5..6,7: ;');
+  Add('  else');
+  Add('  end;');
+  Add('  case f of');
+  Add('  red: ;');
+  Add('  green..blue: ;');
+  Add('  end;');
+  Add('  case b of');
+  Add('  true: ;');
+  Add('  false: ;');
+  Add('  end;');
+  Add('  case c of');
+  Add('  #0: ;');
+  Add('  #10,#13: ;');
+  Add('  ''0''..''9'',''a''..''z'': ;');
+  Add('  end;');
+  Add('  case s of');
+  Add('  #10: ;');
+  Add('  ''abc'': ;');
+  Add('  end;');
+  ParseProgram;
+end;
+
+procedure TTestResolver.TestCaseExprNonOrdFail;
+begin
+  StartProgram(false);
+  Add('begin');
+  Add('  case longint of');
+  Add('  1: ;');
+  Add('  end;');
+  CheckResolverException('ordinal expression expected, but Longint found',
+    nXExpectedButYFound);
+end;
+
+procedure TTestResolver.TestCaseIncompatibleValueFail;
+begin
+  StartProgram(false);
+  Add('var i: longint;');
+  Add('begin');
+  Add('  case i of');
+  Add('  ''1'': ;');
+  Add('  end;');
+  CheckResolverException('Incompatible types: got "Char" expected "Longint"',
+    nIncompatibleTypesGotExpected);
+end;
+
 procedure TTestResolver.TestTryStatement;
 begin
   StartProgram(false);
@@ -4697,67 +4793,6 @@ begin
     nIncompatibleTypesGotExpected);
 end;
 
-procedure TTestResolver.TestCaseOf;
-begin
-  StartProgram(false);
-  Add('type');
-  Add('  TFlag = (red,green,blue);');
-  Add('var');
-  Add('  i: longint;');
-  Add('  f: TFlag;');
-  Add('  b: boolean;');
-  Add('  c: char;');
-  Add('  s: string;');
-  Add('begin');
-  Add('  case i of');
-  Add('  1: ;');
-  Add('  2..3: ;');
-  Add('  4,5..6,7: ;');
-  Add('  else');
-  Add('  end;');
-  Add('  case f of');
-  Add('  red: ;');
-  Add('  red..green: ;');
-  Add('  end;');
-  Add('  case b of');
-  Add('  true: ;');
-  Add('  false: ;');
-  Add('  end;');
-  Add('  case c of');
-  Add('  #0: ;');
-  Add('  #10,#13: ;');
-  Add('  ''0''..''9'',''a''..''z'': ;');
-  Add('  end;');
-  Add('  case s of');
-  Add('  #10: ;');
-  Add('  ''abc'': ;');
-  Add('  end;');
-  ParseProgram;
-end;
-
-procedure TTestResolver.TestCaseExprNonOrdFail;
-begin
-  StartProgram(false);
-  Add('begin');
-  Add('  case longint of');
-  Add('  1: ;');
-  Add('  end;');
-  CheckResolverException('ordinal expression expected, but Longint found',
-    nXExpectedButYFound);
-end;
-
-procedure TTestResolver.TestCaseIncompatibleValueFail;
-begin
-  StartProgram(false);
-  Add('var i: longint;');
-  Add('begin');
-  Add('  case i of');
-  Add('  ''1'': ;');
-  Add('  end;');
-  CheckResolverException('Incompatible types: got "Char" expected "Longint"',
-    nIncompatibleTypesGotExpected);
-end;
-
 procedure TTestResolver.TestSimpleStatement_VarFail;
 begin
   StartProgram(false);