fcl-passrc: useanalyzer: com interfaces

git-svn-id: trunk@38695 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1642,6 +1642,9 @@ type
     function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
     function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
     function IsTypeCast(Params: TParamsExpr): boolean;
+    function IsInterfaceType(const ResolvedEl: TPasResolverResult;
+      IntfType: TPasClassInterfaceType): boolean; overload;
+    function IsInterfaceType(TypeEl: TPasType; IntfType: TPasClassInterfaceType): boolean; overload;
     function ProcNeedsParams(El: TPasProcedureType): boolean;
     function IsProcOverride(AncestorProc, DescendantProc: TPasProcedure): boolean;
     function GetTopLvlProc(El: TPasElement): TPasProcedure;
@@ -4148,8 +4151,10 @@ begin
 
   ModScope.BoolSwitches:=CurrentParser.Scanner.CurrentBoolSwitches;
   if bsRangeChecks in ModScope.BoolSwitches then
+    begin
     Include(ModScope.Flags,pmsfRangeErrorNeeded);
-  FindRangeErrorConstructors(CurModule);
+    FindRangeErrorConstructors(CurModule);
+    end;
 
   if (CurModuleClass=TPasProgram) then
     begin
@@ -17068,6 +17073,23 @@ begin
     exit(true);
 end;
 
+function TPasResolver.IsInterfaceType(const ResolvedEl: TPasResolverResult;
+  IntfType: TPasClassInterfaceType): boolean;
+begin
+  if ResolvedEl.BaseType<>btContext then exit(false);
+  Result:=IsInterfaceType(ResolvedEl.TypeEl,IntfType);
+end;
+
+function TPasResolver.IsInterfaceType(TypeEl: TPasType;
+  IntfType: TPasClassInterfaceType): boolean;
+begin
+  if TypeEl=nil then exit(false);
+  TypeEl:=ResolveAliasType(TypeEl);
+  Result:=(TypeEl.ClassType=TPasClassType)
+    and (TPasClassType(TypeEl).ObjKind=okInterface)
+    and (TPasClassType(TypeEl).InterfaceType=IntfType);
+end;
+
 function TPasResolver.ProcNeedsParams(El: TPasProcedureType): boolean;
 begin
   Result:=(El.Args.Count>0) and (TPasArgument(El.Args[0]).ValueExpr=nil);

packages/fcl-passrc/src/pasuseanalyzer.pas

@@ -74,8 +74,6 @@ const
   sPAPrivateConstXNeverUsed = 'Private const "%s" never used';
   nPAPrivatePropertyXNeverUsed = 5073;
   sPAPrivatePropertyXNeverUsed = 'Private property "%s" never used';
-  //nPAUnreachableCode = 6018;
-  //sPAUnreachableCode = 'unreachable code';
 
 type
   EPasAnalyzer = class(EPasResolve);
@@ -1591,10 +1589,39 @@ procedure TPasAnalyzer.UseClassType(El: TPasClassType; Mode: TPAUseMode);
       end;
   end;
 
+  procedure MarkAllInterfaceImplementations(Scope: TPasClassScope);
+  var
+    i, j: Integer;
+    o: TObject;
+    Map: TPasClassIntfMap;
+  begin
+    if Scope.Interfaces=nil then exit;
+    for i:=0 to Scope.Interfaces.Count-1 do
+      begin
+      o:=TObject(Scope.Interfaces[i]);
+      if o is TPasProperty then
+        UseVariable(TPasProperty(o),rraRead,false)
+      else if o is TPasClassIntfMap then
+        begin
+        Map:=TPasClassIntfMap(o);
+        repeat
+          if Map.Intf<>nil then
+            UseClassType(TPasClassType(Map.Intf),paumElement);
+          if Map.Procs<>nil then
+            for j:=0 to Map.Procs.Count-1 do
+              UseProcedure(TPasProcedure(Map.Procs[j]));
+          Map:=Map.AncestorMap;
+        until Map=nil;
+        end
+      else
+        RaiseNotSupported(20180405190114,El,GetObjName(o));
+      end;
+  end;
+
 var
   i: Integer;
   Member: TPasElement;
-  AllPublished, FirstTime: Boolean;
+  AllPublished, FirstTime, IsCOMInterfaceRoot: Boolean;
   ProcScope: TPasProcedureScope;
   ClassScope: TPasClassScope;
   Ref: TResolvedReference;
@@ -1636,6 +1663,7 @@ begin
   if ClassScope=nil then
     exit; // ClassScope can be nil if msIgnoreInterfaces
 
+  IsCOMInterfaceRoot:=false;
   if FirstTime then
     begin
     UseElType(El,ClassScope.DirectAncestor,paumElement);
@@ -1643,7 +1671,15 @@ begin
     UseExpr(El.GUIDExpr);
     // El.Interfaces: using a class does not use automatically the interfaces
     if El.ObjKind=okInterface then
+      begin
       UseDelegations;
+      if (El.InterfaceType=citCom) and (El.AncestorType=nil) then
+        IsCOMInterfaceRoot:=true;
+      end;
+    if (El.ObjKind=okClass) and (ScopeModule<>nil)
+        and (ClassScope.Interfaces<>nil) then
+      // when checking a single unit, mark all method+properties implementing the interfaces
+      MarkAllInterfaceImplementations(ClassScope);
     end;
   // members
   AllPublished:=(Mode<>paumAllExports);
@@ -1660,10 +1696,34 @@ begin
         if ScopeModule<>nil then
           begin
           // when analyzing a single module, all overrides are assumed to be called
-          UseElement(Member,rraNone,true);
+          UseProcedure(TPasProcedure(Member));
           continue;
           end;
         end;
+      if IsCOMInterfaceRoot then
+        begin
+        case lowercase(Member.Name) of
+        'queryinterface':
+          if (TPasProcedure(Member).ProcType.Args.Count=2) then
+            begin
+            UseProcedure(TPasProcedure(Member));
+            continue;
+            end;
+        '_addref':
+          if TPasProcedure(Member).ProcType.Args.Count=0 then
+            begin
+            UseProcedure(TPasProcedure(Member));
+            continue;
+            end;
+        '_release':
+          if TPasProcedure(Member).ProcType.Args.Count=0 then
+            begin
+            UseProcedure(TPasProcedure(Member));
+            continue;
+            end;
+        end;
+        //writeln('TPasAnalyzer.UseClassType ',El.FullName,' ',Mode,' ',Member.Name);
+        end;
       end;
     if AllPublished and (Member.Visibility=visPublished) then
       begin

packages/fcl-passrc/tests/tcuseanalyzer.pas

@@ -78,9 +78,11 @@ type
     procedure TestM_Class_MethodOverride;
     procedure TestM_Class_MethodOverride2;
     {$IFDEF EnableInterfaces}
-    procedure TestM_ClassInterface;
+    procedure TestM_ClassInterface_Corba;
     procedure TestM_ClassInterface_NoHintsForMethod;
+    procedure TestM_ClassInterface_NoHintsForImpl;
     procedure TestM_ClassInterface_Delegation;
+    procedure TestM_ClassInterface_COM;
     {$ELSE}
     procedure TestM_ClassInterface_Ignore;
     {$ENDIF}
@@ -1056,7 +1058,7 @@ begin
 end;
 
 {$IFDEF EnableInterfaces}
-procedure TTestUseAnalyzer.TestM_ClassInterface;
+procedure TTestUseAnalyzer.TestM_ClassInterface_Corba;
 begin
   StartProgram(false);
   Add([
@@ -1108,6 +1110,36 @@ begin
   CheckUseAnalyzerUnexpectedHints;
 end;
 
+procedure TTestUseAnalyzer.TestM_ClassInterface_NoHintsForImpl;
+begin
+  AddModuleWithIntfImplSrc('unit2.pp',
+    LinesToStr([
+    '{$interfaces corba}',
+    'type',
+    '  IBird = interface',
+    '    procedure DoIt;',
+    '  end;',
+    '']),
+    LinesToStr([
+    '']));
+
+  StartUnit(true);
+  Add([
+  '{$interfaces corba}',
+  'interface',
+  'uses unit2;',
+  'type',
+  '  {#tobject_used}TObject = class(IBird)',
+  '  strict private',
+  '    procedure {#tobject_doit_used}DoIt;',
+  '  end;',
+  'implementation',
+  'procedure TObject.DoIt; begin end;',
+  '']);
+  AnalyzeUnit;
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 procedure TTestUseAnalyzer.TestM_ClassInterface_Delegation;
 begin
   StartProgram(false);
@@ -1143,6 +1175,52 @@ begin
   AnalyzeProgram;
 end;
 
+procedure TTestUseAnalyzer.TestM_ClassInterface_COM;
+begin
+  StartProgram(false);
+  Add([
+  '{$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;',
+  '  {#tobject_used}TObject = class',
+  '  end;',
+  '  {#tbird_used}TBird = class(TObject,IUnknown)',
+  '  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;',
+  '  end;',
+  '  {#teagle_used}TEagle = class(TBird)',
+  '  end;',
+  '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;',
+  'var',
+  '  e: TEagle;',
+  '  i: IUnknown;',
+  'begin',
+  '  i:=e;',
+  '  if i=nil then ;',
+  '']);
+  AnalyzeProgram;
+  CheckUseAnalyzerHint(mtHint,nPALocalXYNotUsed,'Local procedure "DoIt" not used');
+  CheckUseAnalyzerHint(mtHint,nPAPrivateMethodIsNeverUsed,'Private method "TBird.DoIt" is never used');
+  CheckUseAnalyzerUnexpectedHints;
+end;
+
 {$ELSE}
 procedure TTestUseAnalyzer.TestM_ClassInterface_Ignore;
 begin