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

fcl-passrc: fixed generic proc overload

Browse Source 
git-svn-id: trunk@43077 -
This commit is contained in:
Mattias Gaertner 2019-09-26 06:35:46 +00:00
parent 3949be6989
commit 331f8cd051
2 changed files with 69 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9812,6 +9812,7 @@ begin
InlParams:=ParentParams.InlineSpec.Params
else
InlParams:=nil;
//writeln('TPasResolver.ResolveNameExpr Inline=',GetObjName(ParentParams.InlineSpec),' Params=',GetObjName(ParentParams.Params),' ',GetObjPath(El));
if ParentParams.Params<>nil then
begin
case ParentParams.Params.Kind of
@ -9830,11 +9831,10 @@ begin
TypeCnt:=InlParams.Count;
// ToDo: generic functions without params
DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El);
if DeclEl is TPasGenericType then
if DeclEl<>nil then
begin
// GenType<params> -> create specialize type
DeclEl:=GetSpecializedEl(ParentParams.InlineSpec,TPasGenericType(DeclEl),
InlParams);
// GenType<params> -> create specialize type/proc
DeclEl:=GetSpecializedEl(ParentParams.InlineSpec,DeclEl,InlParams);
end
else
RaiseXExpectedButYFound(20190916160829,'generic type',GetElementTypeName(DeclEl),El);
@ -10473,6 +10473,9 @@ var
GenTemplates: TFPList;
begin
// e.g. Name() -> find compatible
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.ResolveFuncParamsExprName NameExpr=',GetObjName(NameExpr),' TemplParams=',TemplParams<>nil,' CallName="',CallName,'"');
{$ENDIF}
if CallName<>'' then
else if NameExpr.ClassType=TPrimitiveExpr then
CallName:=TPrimitiveExpr(NameExpr).Value

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

@ -129,17 +129,20 @@ type
procedure TestGenProc_BackRef1Fail;
procedure TestGenProc_BackRef2Fail;
procedure TestGenProc_BackRef3Fail;
//procedure TestGenProc_Inference;
procedure TestGenProc_CallSelf;
// ToDo procedure TestGenProc_CallSelfNoParams;
procedure TestGenProc_ForwardConstraints;
procedure TestGenProc_ForwardConstraintsRepeatFail;
procedure TestGenProc_ForwardTempNameMismatch;
procedure TestGenProc_ForwardOverload;
procedure TestGenProc_NestedFail;
procedure TestGenProc_TypeParamCntOverload;
procedure TestGenProc_TypeParamCntOverloadNoParams;
//procedure TestGenProc_Inference;
// generic methods
procedure TestGenMethod_VirtualFail;
// ToDo: virtual method cannot have type parameters
// ToDo: message method cannot have type parameters
// ToDo: class interface method cannot have type parameters
procedure TestGenMethod_ClassInterfaceMethodFail;
// ToDo: parametrized method mismatch interface method
// ToDo: generic class method overload <T> <S,T>
// ToDo: generic class method overload <T>(bool) <T>(word)
@ -1970,6 +1973,48 @@ begin
CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX);
end;
procedure TTestResolveGenerics.TestGenProc_TypeParamCntOverload;
begin
StartProgram(false);
Add([
'generic procedure {#A}Run<T>(a: T);',
'begin',
'end;',
'generic procedure {#B}Run<M,N>(a: M);',
'begin',
' specialize {@A}Run<M>(a);',
' specialize {@B}Run<double,char>(1.3);',
'end;',
'begin',
' specialize {@A}Run<word>(3);',
' specialize {@B}Run<word,char>(4);',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_TypeParamCntOverloadNoParams;
begin
StartProgram(false);
Add([
'generic procedure {#A}Run<T>;',
'begin',
'end;',
'generic procedure {#B}Run<M,N>;',
'begin',
' specialize {@A}Run<M>;',
' specialize {@A}Run<M>();',
' specialize {@B}Run<double,char>;',
' specialize {@B}Run<double,char>();',
'end;',
'begin',
' specialize {@A}Run<word>;',
' specialize {@A}Run<word>();',
' specialize {@B}Run<word,char>;',
' specialize {@B}Run<word,char>();',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenMethod_VirtualFail;
begin
StartProgram(false);
@ -1984,6 +2029,19 @@ begin
nXMethodsCannotHaveTypeParams);
end;
procedure TTestResolveGenerics.TestGenMethod_ClassInterfaceMethodFail;
begin
StartProgram(false);
Add([
'type',
' IUnknown = interface',
' generic procedure Run<T>(a: T); virtual; abstract;',
' end;',
'begin',
'']);
CheckParserException('generic is not allowed in interface',nParserXNotAllowedInY);
end;
initialization
RegisterTests([TTestResolveGenerics]);