fcl-passrc: resolver: nicer incompatible types anonymous proc and proc type

git-svn-id: trunk@45531 -

packages/fcl-passrc/src/pasresolver.pp

@@ -22748,11 +22748,14 @@ end;
 
 procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
   ExpType: TPasResolverResult; out GotDesc, ExpDesc: String);
+var
+  NeedProcSignature: Boolean;
 begin
   {$IFDEF VerbosePasResolver}
   writeln('TPasResolver.GetIncompatibleTypeDesc Got={',GetResolverResultDbg(GotType),'} Expected={',GetResolverResultDbg(ExpType),'}');
   {$ENDIF}
-  if GotType.BaseType<>ExpType.BaseType then
+  if (GotType.BaseType<>ExpType.BaseType)
+      and (GotType.BaseType<>btContext) and (ExpType.BaseType<>btContext) then
     begin
     GotDesc:=GetBaseDescription(GotType);
     if ExpType.BaseType=btNil then
@@ -22766,8 +22769,9 @@ begin
     end
   else if (GotType.LoTypeEl<>nil) and (ExpType.LoTypeEl<>nil) then
     begin
-    if (GotType.LoTypeEl.ClassType=ExpType.LoTypeEl.ClassType)
-        and (GotType.LoTypeEl is TPasProcedureType) then
+    NeedProcSignature:=(GotType.LoTypeEl is TPasProcedureType)
+                   and (ExpType.LoTypeEl is TPasProcedureType);
+    if NeedProcSignature then
       begin
       // procedural types
       GetIncompatibleProcParamsDesc(TPasProcedureType(GotType.LoTypeEl),
@@ -22908,6 +22912,12 @@ begin
   GotDesc:=GotDesc+')';
   ExpDesc:=ExpDesc+')';
 
+  // function result
+  if GotType is TPasFunctionType then
+    GotDesc:=GotDesc+': '+GetTypeDescription(ResolveAliasType(TPasFunctionType(GotType).ResultEl.ResultType));
+  if ExpType is TPasFunctionType then
+    ExpDesc:=ExpDesc+': '+GetTypeDescription(ResolveAliasType(TPasFunctionType(ExpType).ResultEl.ResultType));
+
   // modifiers
   if (ptmOfObject in GotType.Modifiers) and not (ptmOfObject in ExpType.Modifiers) then
     GotDesc:=GotDesc+' of Object'
@@ -22921,10 +22931,21 @@ begin
     GotDesc:=GotDesc+'; static'
   else if not (ptmStatic in GotType.Modifiers) and (ptmStatic in ExpType.Modifiers) then
     ExpDesc:=ExpDesc+'; static';
+  if (ptmAsync in GotType.Modifiers) and not (ptmAsync in ExpType.Modifiers) then
+    GotDesc:=GotDesc+'; async'
+  else if not (ptmAsync in GotType.Modifiers) and (ptmAsync in ExpType.Modifiers) then
+    ExpDesc:=ExpDesc+'; async';
   if (ptmVarargs in GotType.Modifiers) and not (ptmVarargs in ExpType.Modifiers) then
     GotDesc:=GotDesc+'; varargs'
   else if not (ptmVarargs in GotType.Modifiers) and (ptmVarargs in ExpType.Modifiers) then
-    ExpDesc:=ExpDesc+'; varargs';
+    ExpDesc:=ExpDesc+'; varargs'
+  else
+    begin
+    if GotType.VarArgsType<>nil then
+      GotDesc:=GotDesc+'; varargs of '+GetTypeDescription(ResolveAliasType(GotType.VarArgsType));
+    if ExpType.VarArgsType<>nil then
+      ExpDesc:=ExpDesc+'; varargs of '+GetTypeDescription(ResolveAliasType(ExpType.VarArgsType));
+    end;
 
   // calling convention
   if GotType.CallingConvention<>ExpType.CallingConvention then
@@ -22932,6 +22953,14 @@ begin
     GotDesc:=GotDesc+';'+cCallingConventions[GotType.CallingConvention];
     ExpDesc:=ExpDesc+';'+cCallingConventions[ExpType.CallingConvention];
     end;
+
+  if GotDesc=ExpDesc then
+    begin
+    if GotType.Parent is TPasAnonymousProcedure then
+      GotDesc:='anonymous '+GotDesc;
+    if ExpType.Parent is TPasAnonymousProcedure then
+      ExpDesc:='anonymous '+ExpDesc;
+    end;
 end;
 
 function TPasResolver.CheckCallProcCompatibility(ProcType: TPasProcedureType;
@@ -24588,7 +24617,7 @@ begin
         end;
       if RaiseOnIncompatible then
         RaiseIncompatibleTypeRes(20170216152444,nIncompatibleTypesGotExpected,
-          [],LHS,RHS,LErrorEl)
+          [],RHS,LHS,LErrorEl)
       else
         exit(cIncompatible);
     end

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -108,6 +108,7 @@ type
 
     // generic procedure type
     procedure TestGen_ProcType;
+    procedure TestGen_ProcType_AnonymousFunc_Delphi;
 
     // pointer of generic
     procedure TestGen_PointerDirectSpecializeFail;
@@ -1730,6 +1731,51 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolveGenerics.TestGen_ProcType_AnonymousFunc_Delphi;
+begin
+  StartProgram(false);
+  Add([
+  '{$mode delphi}',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  IInterface = interface',
+  '  end;',
+  '  Integer = longint;',
+  '  IComparer<T> = interface',
+  '    function Compare(const Left, Right: T): Integer; overload;',
+  '  end;',
+  '  TOnComparison<T> = function(const Left, Right: T): Integer of object;',
+  '  TComparisonFunc<T> = reference to function(const Left, Right: T): Integer;',
+  '  TComparer<T> = class(TObject, IComparer<T>)',
+  '  public',
+  '    function Compare(const Left, Right: T): Integer; overload;',
+  '    class function Construct(const AComparison: TOnComparison<T>): IComparer<T>; overload;',
+  '    class function Construct(const AComparison: TComparisonFunc<T>): IComparer<T>; overload;',
+  '  end;',
+  'function TComparer<T>.Compare(const Left, Right: T): Integer; overload;',
+  'begin',
+  'end;',
+  'class function TComparer<T>.Construct(const AComparison: TOnComparison<T>): IComparer<T>;',
+  'begin',
+  'end;',
+  'class function TComparer<T>.Construct(const AComparison: TComparisonFunc<T>): IComparer<T>;',
+  'begin',
+  'end;',
+  'procedure Test;',
+  'var',
+  '  aComparer : IComparer<Integer>;',
+  'begin',
+  '  aComparer:=TComparer<Integer>.Construct(function (Const a,b : integer) : integer',
+  '    begin',
+  '      Result:=a-b;',
+  '    end);',
+  'end;',
+  'begin',
+  '  Test;']);
+  ParseModule;
+end;
+
 procedure TTestResolveGenerics.TestGen_PointerDirectSpecializeFail;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcresolver.pas

@@ -4010,7 +4010,7 @@ begin
   Add('  f: TFlag;');
   Add('begin');
   Add('  if f=nil then ;');
-  CheckResolverException('Incompatible types: got "TFlag" expected "Pointer"',
+  CheckResolverException('Incompatible types: got "nil" expected "TFlag"',
     nIncompatibleTypesGotExpected);
 end;
 
@@ -14707,7 +14707,7 @@ begin
   Add('  a: array[TEnum] of longint;');
   Add('begin');
   Add('  a:=nil;');
-  CheckResolverException('Incompatible types: got "Nil" expected "static array"',
+  CheckResolverException('Incompatible types: got "nil" expected "static array[] of Longint"',
     nIncompatibleTypesGotExpected);
 end;
 
@@ -15247,7 +15247,7 @@ begin
   '  args:=nil;',
   'end;',
   'begin']);
-  CheckResolverException('Incompatible types: got "Nil" expected "array of const"',nIncompatibleTypesGotExpected);
+  CheckResolverException('Incompatible types: got "nil" expected "array of const"',nIncompatibleTypesGotExpected);
 end;
 
 procedure TTestResolver.TestArrayOfConst_SetLengthFail;