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

fcl-passrc: resolver: fixed call generic function with anonymous specialize function type

Browse Source
This commit is contained in:
mattias 2022-04-21 23:08:19 +02:00
parent 559fcdf736
commit ee7cbb61a0
2 changed files with 63 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -24180,8 +24180,8 @@ function TPasResolver.CheckProcTypeCompatibility(Proc1,
var
ProcArgs1, ProcArgs2: TFPList;
i: Integer;
Result1Resolved, Result2Resolved: TPasResolverResult;
ExpectedArg, ActualArg: TPasArgument;
ResultType1, ResultType2: TPasType;
begin
Result:=false;
if Proc1.ClassType<>Proc2.ClassType then
@ -24276,16 +24276,16 @@ begin
end;
if Proc1 is TPasFunctionType then
begin
ComputeResultElement(TPasFunctionType(Proc1).ResultEl,Result1Resolved,[]);
ComputeResultElement(TPasFunctionType(Proc2).ResultEl,Result2Resolved,[]);
if (Result1Resolved.BaseType<>Result2Resolved.BaseType)
or not IsSameType(Result1Resolved.HiTypeEl,Result2Resolved.HiTypeEl,prraSimple) then
ResultType1:=TPasFunctionType(Proc1).ResultEl.ResultType;
ResultType2:=TPasFunctionType(Proc2).ResultEl.ResultType;
if CheckElTypeCompatibility(ResultType1,ResultType2,prraSimple)>cGenericExact then
begin
if RaiseOnIncompatible then
RaiseIncompatibleTypeRes(20170402112648,nResultTypeMismatchExpectedButFound,
[],Result1Resolved,Result2Resolved,ErrorEl);
RaiseIncompatibleType(20170402112648,nResultTypeMismatchExpectedButFound,
[],ResultType1,ResultType2,ErrorEl);
exit;
end;
if Proc1.IsAsync<>Proc2.IsAsync then
RaiseMsg(20200524112519,nXModifierMismatchY,sXModifierMismatchY,['procedure type','async'],ErrorEl);
end;
@ -24719,6 +24719,7 @@ begin
Result:=-1;
Handled:=false;
// let descendant check first
Result:=CheckAssignCompatibilityCustom(LHS,RHS,ErrorEl,RaiseOnIncompatible,Handled);
if Handled and (Result>=cExact) and (Result<cIncompatible) then
exit;

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

@ -158,6 +158,7 @@ type
procedure TestGenProc_TypeParamWithDefaultParamDelphiFail;
procedure TestGenProc_ParamSpecWithT;
procedure TestGenProc_ParamSpecWithTNestedType;
procedure TestGenProc_ProcType_Anonymous;
// ToDo: NestedResultAssign
// generic function infer types
@ -173,7 +174,8 @@ type
procedure TestGenProc_Infer_ArrayOfT;
procedure TestGenProc_Infer_PassAsArgDelphi;
procedure TestGenProc_Infer_PassAsArgObjFPC;
// ToDo procedure TestGenProc_Infer_ProcType;
procedure TestGenProc_Infer_ProcType; // ToDo
// ToDo procedure TestGenProc_Infer_TArray;
// generic methods
procedure TestGenMethod_VirtualFail;
@ -2581,6 +2583,32 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_ProcType_Anonymous;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$ModeSwitch implicitfunctionspecialization}',
'type generic TFunc<T> = function(Arg: T): T;',
'generic function Fly<T>(aFunc: specialize TFunc<T>; Ant: T): T;',
'begin',
' Result:=aFunc(Ant);',
'end;',
'function Jump(Arg: word): word;',
'begin',
'end;',
'procedure Test;',
'var StrFunc: specialize TFunc<string>;',
'begin',
' specialize Fly<string>(StrFunc,''foo'');',
' specialize Fly<word>(@Jump,3);',
'end;',
'begin',
' specialize Fly<word>(@Jump,5);',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Infer_NeedExplicitFail;
begin
StartProgram(false);
@ -2813,6 +2841,32 @@ begin
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenProc_Infer_ProcType;
begin
StartProgram(false);
Add([
'{$mode objfpc}',
'{$ModeSwitch implicitfunctionspecialization}',
'type generic TFunc<T> = function(Arg: T): T;',
'function Jump(w: word): word;',
'begin',
'end;',
'generic function Fly<T>(aFunc: specialize TFunc<T>; Ant: T): T;',
'begin',
' Result:=aFunc(Ant);',
'end;',
'procedure Test;',
'var StrFunc: specialize TFunc<string>;',
'begin',
// ' Fly(StrFunc,''foo'');',
// ' Fly(@Jump,4);',
'end;',
'begin',
// ' Fly(@Jump,6);',
'']);
ParseProgram;
end;
procedure TTestResolveGenerics.TestGenMethod_VirtualFail;
begin
StartProgram(false);