diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index a46596f270..f0d52955e6 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/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); diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index 1e7bceeabd..5863c4104a 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/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 diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index 412d4d3e63..bb5b0d17b3 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/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