paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 16:09:25 +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 InlParams:=ParentParams.InlineSpec.Params
else else
InlParams:=nil; InlParams:=nil;
//writeln('TPasResolver.ResolveNameExpr Inline=',GetObjName(ParentParams.InlineSpec),' Params=',GetObjName(ParentParams.Params),' ',GetObjPath(El));
if ParentParams.Params<>nil then if ParentParams.Params<>nil then
begin begin
case ParentParams.Params.Kind of case ParentParams.Params.Kind of
@ -9830,11 +9831,10 @@ begin
TypeCnt:=InlParams.Count; TypeCnt:=InlParams.Count;
// ToDo: generic functions without params // ToDo: generic functions without params
DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El); DeclEl:=FindGenericEl(aName,TypeCnt,FindData,El);
if DeclEl is TPasGenericType then if DeclEl<>nil then
begin begin
// GenType<params> -> create specialize type // GenType<params> -> create specialize type/proc
DeclEl:=GetSpecializedEl(ParentParams.InlineSpec,TPasGenericType(DeclEl), DeclEl:=GetSpecializedEl(ParentParams.InlineSpec,DeclEl,InlParams);
InlParams);
end end
else else
RaiseXExpectedButYFound(20190916160829,'generic type',GetElementTypeName(DeclEl),El); RaiseXExpectedButYFound(20190916160829,'generic type',GetElementTypeName(DeclEl),El);
@ -10473,6 +10473,9 @@ var
GenTemplates: TFPList; GenTemplates: TFPList;
begin begin
// e.g. Name() -> find compatible // e.g. Name() -> find compatible
{$IFDEF VerbosePasResolver}
//writeln('TPasResolver.ResolveFuncParamsExprName NameExpr=',GetObjName(NameExpr),' TemplParams=',TemplParams<>nil,' CallName="',CallName,'"');
{$ENDIF}
if CallName<>'' then if CallName<>'' then
else if NameExpr.ClassType=TPrimitiveExpr then else if NameExpr.ClassType=TPrimitiveExpr then
CallName:=TPrimitiveExpr(NameExpr).Value CallName:=TPrimitiveExpr(NameExpr).Value

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

@ -129,17 +129,20 @@ type
procedure TestGenProc_BackRef1Fail; procedure TestGenProc_BackRef1Fail;
procedure TestGenProc_BackRef2Fail; procedure TestGenProc_BackRef2Fail;
procedure TestGenProc_BackRef3Fail; procedure TestGenProc_BackRef3Fail;
//procedure TestGenProc_Inference;
procedure TestGenProc_CallSelf; procedure TestGenProc_CallSelf;
// ToDo procedure TestGenProc_CallSelfNoParams;
procedure TestGenProc_ForwardConstraints; procedure TestGenProc_ForwardConstraints;
procedure TestGenProc_ForwardConstraintsRepeatFail; procedure TestGenProc_ForwardConstraintsRepeatFail;
procedure TestGenProc_ForwardTempNameMismatch; procedure TestGenProc_ForwardTempNameMismatch;
procedure TestGenProc_ForwardOverload; procedure TestGenProc_ForwardOverload;
procedure TestGenProc_NestedFail; procedure TestGenProc_NestedFail;
procedure TestGenProc_TypeParamCntOverload;
procedure TestGenProc_TypeParamCntOverloadNoParams;
//procedure TestGenProc_Inference;
// generic methods
procedure TestGenMethod_VirtualFail; procedure TestGenMethod_VirtualFail;
// ToDo: virtual method cannot have type parameters procedure TestGenMethod_ClassInterfaceMethodFail;
// ToDo: message method cannot have type parameters
// ToDo: class interface method cannot have type parameters
// ToDo: parametrized method mismatch interface method // ToDo: parametrized method mismatch interface method
// ToDo: generic class method overload <T> <S,T> // ToDo: generic class method overload <T> <S,T>
// ToDo: generic class method overload <T>(bool) <T>(word) // ToDo: generic class method overload <T>(bool) <T>(word)
@ -1970,6 +1973,48 @@ begin
CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX); CheckResolverException('Type parameters not allowed on nested procedure',nTypeParamsNotAllowedOnX);
end; 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; procedure TTestResolveGenerics.TestGenMethod_VirtualFail;
begin begin
StartProgram(false); StartProgram(false);
@ -1984,6 +2029,19 @@ begin
nXMethodsCannotHaveTypeParams); nXMethodsCannotHaveTypeParams);
end; 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 initialization
RegisterTests([TTestResolveGenerics]); RegisterTests([TTestResolveGenerics]);