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

fcl-passrc: resolver: check proc args procedural type by signature in mode objfpc

Browse Source 
git-svn-id: trunk@44208 -
This commit is contained in:
Mattias Gaertner 2020-02-18 10:16:03 +00:00
parent 06a6bfd981
commit 5ef735ca11
3 changed files with 36 additions and 6 deletions

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

@ -23390,8 +23390,9 @@ var
C: TClass;
Arr1, Arr2: TPasArrayType;
TemplType1, TemplType2: TPasGenericTemplateType;
Templates1, Templates2: TFPList;
Templates1, Templates2, ProcArgs1, ProcArgs2: TFPList;
i: Integer;
Proc1, Proc2: TPasProcedureType;
begin
if Arg1=Arg2 then exit(cExact);
ComputeElement(Arg1,Arg1Resolved,[rcType]);
@ -23439,6 +23440,7 @@ begin
if IsSameType(Arg1Resolved.LoTypeEl,Arg2Resolved.LoTypeEl,prraNone) then
exit(cExact);
end;
if Arg1Resolved.BaseType=btContext then
begin
C:=Arg1Resolved.LoTypeEl.ClassType;
@ -23454,6 +23456,33 @@ begin
RaiseNotYetImplemented(20170328093733,Arr1.Ranges[0],'anonymous static array');
Result:=CheckElTypeCompatibility(GetArrayElType(Arr1),GetArrayElType(Arr2),ResolveAlias);
exit;
end
else if (C.InheritsFrom(TPasProcedureType))
and not (msDelphi in CurrentParser.CurrentModeswitches) then
begin
// FPC checks proc types arguments by signature, Delphi checks by type
Proc1:=TPasProcedureType(Arg1Resolved.LoTypeEl);
Proc2:=TPasProcedureType(Arg2Resolved.LoTypeEl);
if Proc1.CallingConvention<>Proc2.CallingConvention then
exit(cIncompatible);
if Proc1.Modifiers<>Proc2.Modifiers then
exit(cIncompatible);
if Proc1.VarArgsType<>Proc2.VarArgsType then
begin
Result:=CheckElTypeCompatibility(Proc1.VarArgsType,Proc2.VarArgsType,ResolveAlias);
if Result=cIncompatible then exit;
end;
ProcArgs1:=Proc1.Args;
ProcArgs2:=Proc2.Args;
if ProcArgs1.Count<>ProcArgs2.Count then
exit(cIncompatible);
for i:=0 to ProcArgs1.Count-1 do
begin
Result:=CheckProcArgCompatibility(TPasArgument(ProcArgs1[i]),TPasArgument(ProcArgs2[i]));
if Result>cGenericExact then
exit(cIncompatible);
end;
exit(cExact);
end;
end;

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

@ -1438,8 +1438,6 @@ end;
procedure TTestResolveGenerics.TestGen_Class_ReferenceTo;
begin
exit;
StartProgram(false);
Add([
'{$mode objfpc}',
@ -1452,12 +1450,16 @@ begin
' public',
' constructor new(Executor : TGJSPromiseExecutor);',
' end;',
'constructor TGJSPromise.new(Executor : TGJSPromiseExecutor);',
'begin',
'end;',
'',
'type',
' TJSPromise = specialize TGJSPromise<Word>;',
' TJSPromiseResolver = reference to function (aValue : Word) : Word;',
'',
' TURLLoader = Class(TObject)',
' procedure dofetch(resolve, reject: TJSPromiseResolver);',
' procedure dofetch(resolve, reject: TJSPromiseResolver); virtual; abstract;',
' Function fetch : TJSPromise;',
' end;',
'function TURLLoader.fetch : TJSPromise;',

3
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -853,7 +853,7 @@ type
Procedure TestAssignProcToFunctionFail;
Procedure TestAssignProcWrongArgsFail;
Procedure TestAssignProcWrongArgAccessFail;
Procedure TestProcType_SameSignatureObjFPC; // ToDo
Procedure TestProcType_SameSignatureObjFPC;
Procedure TestProcType_AssignNestedProcFail;
Procedure TestArrayOfProc;
Procedure TestProcType_Assigned;
@ -15633,7 +15633,6 @@ end;
procedure TTestResolver.TestProcType_SameSignatureObjFPC;
begin
exit;
StartProgram(false);
Add([
'{$mode objfpc}',