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

fcl-passrc: check delphi generic class method implementation params

Browse Source 
git-svn-id: trunk@42769 -
This commit is contained in:
Mattias Gaertner 2019-08-23 09:33:02 +00:00
parent a7f363e246
commit 26c87910f8
3 changed files with 98 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11552,8 +11552,8 @@ var
CurScope: TPasScope;
LocalScope: TPasScope;
Level, TypeParamCount, i: Integer;
TypeParam: TProcedureNamePart;
TemplType: TPasGenericTemplateType;
NameParams: TProcedureNamePart;
TemplType, FoundTemplType: TPasGenericTemplateType;
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddProcedure ',GetObjName(El));
@ -11674,21 +11674,23 @@ begin
// e.g. aclassname<T>.
if Level>TypeParams.Count then
RaiseNotYetImplemented(20190818122217,El);
TypeParam:=TProcedureNamePart(TypeParams[Level-1]);
if TypeParam.Name<>aClassName then
RaiseNotYetImplemented(20190818102541,El,IntToStr(Level)+': '+TypeParam.Name+'<>'+aClassName);
if TypeParam.Templates<>nil then
NameParams:=TProcedureNamePart(TypeParams[Level-1]);
if NameParams.Name<>aClassName then
RaiseNotYetImplemented(20190818102541,El,IntToStr(Level)+': '+NameParams.Name+'<>'+aClassName);
if NameParams.Templates<>nil then
begin
TypeParamCount:=TypeParam.Templates.Count;
TypeParamCount:=NameParams.Templates.Count;
for i:=0 to TypeParamCount-1 do
begin
TemplType:=TPasGenericTemplateType(TypeParam.Templates[i]);
TemplType:=TPasGenericTemplateType(NameParams.Templates[i]);
if length(TemplType.Constraints)>0 then
RaiseMsg(20190818102850,nXCannotHaveParameters,sXCannotHaveParameters,
[TemplType.Name],TemplType.Constraints[0]);
end;
end;
end;
end
else
NameParams:=nil;
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.AddProcedure searching class "',aClassName,GetTypeParamCommas(TypeParamCount),'" ProcName="',ProcName,'" ...');
{$ENDIF}
@ -11717,6 +11719,18 @@ begin
end;
if ClassOrRecType.GetModule<>El.GetModule then
RaiseNotYetImplemented(20190818120051,El);
if NameParams<>nil then
begin
for i:=0 to TypeParamCount-1 do
begin
TemplType:=TPasGenericTemplateType(NameParams.Templates[i]);
FoundTemplType:=TPasGenericTemplateType(ClassOrRecType.GenericTemplateTypes[i]);
if not SameText(TemplType.Name,FoundTemplType.Name) then
RaiseMsg(20190822014652,nXExpectedButYFound,
sXExpectedButYFound,[FoundTemplType.Name,TemplType.Name],TemplType);
end;
end;
until false;
if not IsValidIdent(ProcName) then
@ -11729,10 +11743,10 @@ begin
begin
if Level<>TypeParams.Count then
RaiseNotYetImplemented(20190818122315,El);
TypeParam:=TProcedureNamePart(TypeParams[Level-1]);
if TypeParam.Name<>ProcName then
RaiseNotYetImplemented(20190818122551,El,IntToStr(Level)+': '+TypeParam.Name+'<>'+ProcName);
if TypeParam.Templates<>nil then
NameParams:=TProcedureNamePart(TypeParams[Level-1]);
if NameParams.Name<>ProcName then
RaiseNotYetImplemented(20190818122551,El,IntToStr(Level)+': '+NameParams.Name+'<>'+ProcName);
if NameParams.Templates<>nil then
begin
// ToDo: generic method
RaiseNotYetImplemented(20190818122619,El);

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

@ -2516,6 +2516,7 @@ var
i: Integer;
Decl: TPasElement;
Usage: TPAElement;
GenScope: TPasGenericScope;
begin
{$IFDEF VerbosePasAnalyzer}
writeln('TPasAnalyzer.EmitDeclarationsHints ',GetElModName(El));
@ -2537,6 +2538,12 @@ begin
if Usage=nil then
begin
// declaration was never used
if Decl is TPasGenericType then
begin
GenScope:=Decl.CustomData as TPasGenericScope;
if GenScope.SpecializedItem<>nil then
continue;
end;
EmitMessage(20170311231734,mtHint,nPALocalXYNotUsed,
sPALocalXYNotUsed,[Decl.ElementTypeName,Decl.Name],Decl);
end;
@ -2551,6 +2558,7 @@ var
i: Integer;
Member: TPasElement;
Members: TFPList;
GenScope: TPasGenericScope;
begin
{$IFDEF VerbosePasAnalyzer}
writeln('TPasAnalyzer.EmitTypeHints ',GetElModName(El));
@ -2566,6 +2574,12 @@ begin
begin
if (El is TPasClassType) and (TPasClassType(El).ObjKind=okInterface) then
exit;
if El is TPasGenericType then
begin
GenScope:=El.CustomData as TPasGenericScope;
if GenScope.SpecializedItem<>nil then
exit;
end;
EmitMessage(20170312000025,mtHint,nPALocalXYNotUsed,
sPALocalXYNotUsed,[El.ElementTypeName,El.Name],El);

59
packages/fcl-passrc/tests/tcresolvegenerics.pas
View File

@ -59,8 +59,9 @@ type
procedure TestGen_Class_Method;
procedure TestGen_Class_MethodOverride;
procedure TestGen_Class_MethodDelphi;
// ToDo: procedure TestGen_Class_MethodDelphiTypeParamMissing;
// ToDo: procedure TestGen_Class_MethodImplConstraintFail;
procedure TestGen_Class_MethodDelphiTypeParamMissing;
procedure TestGen_Class_MethodImplConstraintFail;
procedure TestGen_Class_MethodImplTypeParamNameMismatch;
procedure TestGen_Class_SpecializeSelfInside;
procedure TestGen_Class_GenAncestor;
procedure TestGen_Class_AncestorSelfFail;
@ -721,6 +722,60 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGen_Class_MethodDelphiTypeParamMissing;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TBird<T> = class',
' function Run(p:T): T;',
' end;',
'function TBird.Run(p:T): T;',
'begin',
'end;',
'begin',
'']);
CheckResolverException('TBird<> expected, but TBird found',nXExpectedButYFound);
end;
procedure TTestResolveGenerics.TestGen_Class_MethodImplConstraintFail;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TBird<T: record> = class',
' function Run(p:T): T;',
' end;',
'function TBird<T: record>.Run(p:T): T;',
'begin',
'end;',
'begin',
'']);
CheckResolverException('T cannot have parameters',nXCannotHaveParameters);
end;
procedure TTestResolveGenerics.TestGen_Class_MethodImplTypeParamNameMismatch;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TObject = class end;',
' TBird<T> = class',
' procedure DoIt;',
' end;',
'procedure TBird<S>.DoIt;',
'begin',
'end;',
'begin',
'']);
CheckResolverException('T expected, but S found',nXExpectedButYFound);
end;
procedure TTestResolveGenerics.TestGen_Class_SpecializeSelfInside;
begin
StartProgram(false);