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

fcl-passrc: on incompatible procedural arg types write params

Browse Source 
git-svn-id: trunk@44207 -
This commit is contained in:
Mattias Gaertner 2020-02-18 09:50:47 +00:00
parent 2214677656
commit 06a6bfd981
2 changed files with 65 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22613,16 +22613,10 @@ procedure TPasResolver.RaiseIncompatibleType(id: TMaxPrecInt; MsgNumber: integer
const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
GotType, ExpType: TPasType; ErrorEl: TPasElement);
var
DescA, DescB: String;
GotDesc, ExpDesc: String;
begin
DescA:=GetTypeDescription(GotType);
DescB:=GetTypeDescription(ExpType);
if DescA=DescB then
begin
DescA:=GetTypeDescription(GotType,true);
DescB:=GetTypeDescription(ExpType,true);
end;
RaiseIncompatibleTypeDesc(id,MsgNumber,Args,DescA,DescB,ErrorEl);
GetIncompatibleTypeDesc(GotType,ExpType,GotDesc,ExpDesc);
RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl);
end;
procedure TPasResolver.RaiseIncompatibleTypeRes(id: TMaxPrecInt; MsgNumber: integer;
@ -22784,50 +22778,66 @@ begin
ExpDesc:=BaseTypeNames[btPointer]
else
ExpDesc:=GetBaseDescription(ExpType);
if GotDesc=ExpDesc then
begin
GotDesc:=GetBaseDescription(GotType,true);
ExpDesc:=GetBaseDescription(ExpType,true);
end;
if GotDesc<>ExpDesc then
exit;
GotDesc:=GetBaseDescription(GotType,true);
ExpDesc:=GetBaseDescription(ExpType,true);
end
else if (GotType.LoTypeEl<>nil) and (ExpType.LoTypeEl<>nil) then
begin
if (GotType.LoTypeEl.ClassType=ExpType.LoTypeEl.ClassType)
and (GotType.LoTypeEl is TPasProcedureType) then
begin
// procedural types
GetIncompatibleProcParamsDesc(TPasProcedureType(GotType.LoTypeEl),
TPasProcedureType(ExpType.LoTypeEl),GotDesc,ExpDesc)
else
begin
GotDesc:=GetTypeDescription(GotType);
ExpDesc:=GetTypeDescription(ExpType);
if (GotDesc=ExpDesc) and (GotType.HiTypeEl<>ExpType.HiTypeEl) then
begin
GotDesc:=GetTypeDescription(GotType.HiTypeEl);
ExpDesc:=GetTypeDescription(ExpType.HiTypeEl);
end;
if GotDesc=ExpDesc then
begin
GotDesc:=GetTypeDescription(GotType,true);
ExpDesc:=GetTypeDescription(ExpType,true);
end;
TPasProcedureType(ExpType.LoTypeEl),GotDesc,ExpDesc);
if GotDesc<>ExpDesc then
exit;
end;
GotDesc:=GetTypeDescription(GotType);
ExpDesc:=GetTypeDescription(ExpType);
if GotDesc<>ExpDesc then
exit;
if GotType.HiTypeEl<>ExpType.HiTypeEl then
begin
GotDesc:=GetTypeDescription(GotType.HiTypeEl);
ExpDesc:=GetTypeDescription(ExpType.HiTypeEl);
if GotDesc<>ExpDesc then
exit;
end;
GotDesc:=GetTypeDescription(GotType,true);
ExpDesc:=GetTypeDescription(ExpType,true);
end
else
begin
GotDesc:=GetResolverResultDescription(GotType,true);
ExpDesc:=GetResolverResultDescription(ExpType,true);
if GotDesc=ExpDesc then
begin
GotDesc:=GetResolverResultDescription(GotType,false);
ExpDesc:=GetResolverResultDescription(ExpType,false);
end;
if GotDesc<>ExpDesc then
exit;
GotDesc:=GetResolverResultDescription(GotType,false);
ExpDesc:=GetResolverResultDescription(ExpType,false);
end;
end;
procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
ExpType: TPasType; out GotDesc, ExpDesc: String);
var
GotLoType, ExpLoType: TPasType;
begin
GotLoType:=ResolveAliasType(GotType);
ExpLoType:=ResolveAliasType(ExpType);
if (GotLoType<>nil) and (ExpLoType<>nil) then
begin
if (GotLoType.ClassType=ExpLoType.ClassType)
and (GotLoType is TPasProcedureType) then
begin
// procedural types
GetIncompatibleProcParamsDesc(TPasProcedureType(GotLoType),
TPasProcedureType(ExpLoType),GotDesc,ExpDesc);
if GotDesc<>ExpDesc then
exit;
end;
end;
GotDesc:=GetTypeDescription(GotType);
ExpDesc:=GetTypeDescription(ExpType);
if GotDesc<>ExpDesc then exit;

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

@ -853,6 +853,7 @@ type
Procedure TestAssignProcToFunctionFail;
Procedure TestAssignProcWrongArgsFail;
Procedure TestAssignProcWrongArgAccessFail;
Procedure TestProcType_SameSignatureObjFPC; // ToDo
Procedure TestProcType_AssignNestedProcFail;
Procedure TestArrayOfProc;
Procedure TestProcType_Assigned;
@ -15630,6 +15631,26 @@ begin
nIncompatibleTypeArgNo);
end;
procedure TTestResolver.TestProcType_SameSignatureObjFPC;
begin
exit;
StartProgram(false);
Add([
'{$mode objfpc}',
'type',
' TRun = procedure(a: Word);',
' TRunIt = procedure(a: TRun);',
' TFly = procedure(a: Word);',
'procedure FlyIt(a: TFly);',
'begin',
'end;',
'var RunIt: TRunIt;',
'begin',
' RunIt:=@FlyIt;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestProcType_AssignNestedProcFail;
begin
StartProgram(false);