fcl-passrc: resolver: check ancestor interfaces

git-svn-id: trunk@39182 -

packages/fcl-passrc/src/pasresolver.pp

@@ -745,7 +745,7 @@ type
     Element: TPasElement;
     Intf: TPasClassType;
     Procs: TFPList;// maps Interface-member-index to TPasProcedure
-    AncestorMap: TPasClassIntfMap;
+    AncestorMap: TPasClassIntfMap;// AncestorMap.Element=Element, AncestorMap.Intf=DirectAncestor
     destructor Destroy; override;
   end;
 
@@ -755,7 +755,7 @@ type
   public
     AncestorScope: TPasClassScope;
     CanonicalClassOf: TPasClassOfType;
-    DirectAncestor: TPasType; // TPasClassType or TPasAliasType
+    DirectAncestor: TPasType; // TPasClassType or TPasAliasType, see GetPasClassAncestor
     DefaultProperty: TPasProperty;
     Flags: TPasClassScopeFlags;
     AbstractProcs: TArrayOfPasProcedure;
@@ -4860,6 +4860,7 @@ begin
         while Map<>nil do
           begin
           IntfType:=Map.Intf;
+          //writeln('TPasResolver.FinishClassType ',GetObjName(Map),' ',GetObjName(IntfType),' Count=',IntfType.Members.Count);
           for j:=0 to IntfType.Members.Count-1 do
             begin
             Member:=TPasElement(IntfType.Members[j]);
@@ -6559,7 +6560,7 @@ begin
     Map.Intf:=IntfType;
     Map.Procs:=TFPList.Create;
     Map.Procs.Count:=IntfType.Members.Count;
-    IntfType:=TPasClassType(ResolveAliasType(IntfType.AncestorType));
+    IntfType:=GetPasClassAncestor(IntfType,true) as TPasClassType;
     end;
 end;
 
@@ -19675,17 +19676,13 @@ end;
 
 function TPasResolver.GetClassImplementsIntf(ClassEl, Intf: TPasClassType
   ): TPasClassType;
-var
-  AncestorType: TPasType;
 begin
   Result:=nil;
   while ClassEl<>nil do
     begin
     if IndexOfImplementedInterface(ClassEl,Intf)>=0 then
       exit(ClassEl);
-    AncestorType:=ResolveAliasType(ClassEl.AncestorType);
-    if AncestorType=nil then exit;
-    ClassEl:=TPasClassType(AncestorType);
+    ClassEl:=GetPasClassAncestor(ClassEl,true) as TPasClassType;
     end;
 end;
 

packages/fcl-passrc/src/pastree.pp

@@ -702,8 +702,9 @@ type
   public
     PackMode: TPackMode;
     ObjKind: TPasObjKind;
-    AncestorType: TPasType;     // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
-    HelperForType: TPasType;     // TPasClassType or TPasUnresolvedTypeRef
+    AncestorType: TPasType;   // TPasClassType or TPasUnresolvedTypeRef or TPasAliasType or TPasTypeAliasType
+                              // Note: AncestorType can be nil even though it has a default ancestor
+    HelperForType: TPasType;  // TPasClassType or TPasUnresolvedTypeRef
     IsForward: Boolean;
     IsExternal : Boolean;
     IsShortDefinition: Boolean;//class(anchestor); without end

packages/fcl-passrc/tests/tcresolver.pas

@@ -651,6 +651,7 @@ type
     Procedure TestClassInterface_IntfListClassFail;
     Procedure TestClassInterface_IntfListDuplicateFail;
     Procedure TestClassInterface_MissingMethodFail;
+    Procedure TestClassInterface_MissingAncestorMethodFail;
     Procedure TestClassInterface_DefaultProperty;
     Procedure TestClassInterface_MethodResolution;
     Procedure TestClassInterface_MethodResolutionDuplicateFail;
@@ -10997,6 +10998,23 @@ begin
     nNoMatchingImplForIntfMethodXFound);
 end;
 
+procedure TTestResolver.TestClassInterface_MissingAncestorMethodFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  IUnknown = interface',
+  '    procedure DoIt;',
+  '  end;',
+  '  IBird = interface',
+  '  end;',
+  '  TObject = class(IBird)',
+  '  end;',
+  'begin']);
+  CheckResolverException('No matching implementation for interface method "procedure IUnknown.DoIt of Object" found',
+    nNoMatchingImplForIntfMethodXFound);
+end;
+
 procedure TTestResolver.TestClassInterface_DefaultProperty;
 begin
   StartProgram(false);

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -154,6 +154,7 @@ type
     procedure TestWP_ClassInterface_OneWayIntfToObj;
     procedure TestWP_ClassInterface_Delegation;
     procedure TestWP_ClassInterface_COM;
+    procedure TestWP_ClassInterface_COM_Unit;
     procedure TestWP_ClassInterface_Typeinfo;
     procedure TestWP_ClassInterface_TGUID;
 
@@ -2772,6 +2773,63 @@ begin
   AnalyzeWholeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestWP_ClassInterface_COM_Unit;
+begin
+  AddModuleWithIntfImplSrc('SysUtils.pas',
+    LinesToStr([
+    '{$interfaces com}',
+    'type',
+    '  {#tguid_used}TGuid = string;',
+    '  {#integer_used}integer = longint;',
+    '  {#iunknown_used}IUnknown = interface',
+    '    function {#iunknown_queryintf_used}QueryInterface(const iid: TGuid; out obj): Integer;',
+    '    function {#iunknown_addref_used}_AddRef: Integer;',
+    '    function {#iunknown_release_used}_Release: Integer;',
+    '    procedure {#iunknown_doit_notused}DoIt;',
+    '  end;',
+    '  IBird = interface(IUnknown)',
+    '    procedure {#ibird_fly_used}Fly;',
+    '  end;',
+    '  {#tobject_used}TObject = class',
+    '  end;',
+    '  {#tbird_used}TBird = class(TObject,IBird)',
+    '  strict private',
+    '    function {#tbird_queryintf_used}QueryInterface(const iid: TGuid; out obj): Integer;',
+    '    function {#tbird_addref_used}_AddRef: Integer;',
+    '    function {#tbird_release_used}_Release: Integer;',
+    '    procedure {#tbird_doit_notused}DoIt;',
+    '    procedure {#tbird_fly_used}Fly;',
+    '  end;',
+    '']),
+    LinesToStr([
+    'function TBird.QueryInterface(const iid: TGuid; out obj): Integer;',
+    'begin',
+    '  if iid='''' then obj:=nil;',
+    '  Result:=0;',
+    'end;',
+    'function TBird._AddRef: Integer; begin Result:=1; end;',
+    'function TBird._Release: Integer; begin Result:=2; end;',
+    'procedure TBird.DoIt; begin end;',
+    'procedure TBird.Fly; begin end;',
+    '']) );
+
+  StartProgram(true);
+  Add([
+  'uses sysutils;',
+  'type',
+  '  {#teagle_used}TEagle = class(TBird)',
+  '  end;',
+  'var',
+  '  e: TEagle;',
+  '  i: IBird;',
+  'begin',
+  '  i:=e;',
+  '  if i=nil then ;',
+  '  i.Fly;',
+  '']);
+  AnalyzeWholeProgram;
+end;
+
 procedure TTestUseAnalyzer.TestWP_ClassInterface_Typeinfo;
 begin
   StartProgram(false);