paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-10 09:49:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: useanalyzer: com interfaces

Browse Source 
git-svn-id: trunk@38695 -
This commit is contained in:
Mattias Gaertner 2018-04-06 10:37:45 +00:00
parent 254aa0e9e1
commit 835c1c8f1a
3 changed files with 167 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
packages/fcl-passrc/src/pasresolver.pp
View File

@ -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);

68
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -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

82
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -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