paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 17:39:20 +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}; const Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
GotType, ExpType: TPasType; ErrorEl: TPasElement); GotType, ExpType: TPasType; ErrorEl: TPasElement);
var var
DescA, DescB: String; GotDesc, ExpDesc: String;
begin begin
DescA:=GetTypeDescription(GotType); GetIncompatibleTypeDesc(GotType,ExpType,GotDesc,ExpDesc);
DescB:=GetTypeDescription(ExpType); RaiseIncompatibleTypeDesc(id,MsgNumber,Args,GotDesc,ExpDesc,ErrorEl);
if DescA=DescB then
begin
DescA:=GetTypeDescription(GotType,true);
DescB:=GetTypeDescription(ExpType,true);
end;
RaiseIncompatibleTypeDesc(id,MsgNumber,Args,DescA,DescB,ErrorEl);
end; end;
procedure TPasResolver.RaiseIncompatibleTypeRes(id: TMaxPrecInt; MsgNumber: integer; procedure TPasResolver.RaiseIncompatibleTypeRes(id: TMaxPrecInt; MsgNumber: integer;
@ -22784,50 +22778,66 @@ begin
ExpDesc:=BaseTypeNames[btPointer] ExpDesc:=BaseTypeNames[btPointer]
else else
ExpDesc:=GetBaseDescription(ExpType); ExpDesc:=GetBaseDescription(ExpType);
if GotDesc=ExpDesc then if GotDesc<>ExpDesc then
begin exit;
GotDesc:=GetBaseDescription(GotType,true); GotDesc:=GetBaseDescription(GotType,true);
ExpDesc:=GetBaseDescription(ExpType,true); ExpDesc:=GetBaseDescription(ExpType,true);
end;
end end
else if (GotType.LoTypeEl<>nil) and (ExpType.LoTypeEl<>nil) then else if (GotType.LoTypeEl<>nil) and (ExpType.LoTypeEl<>nil) then
begin begin
if (GotType.LoTypeEl.ClassType=ExpType.LoTypeEl.ClassType) if (GotType.LoTypeEl.ClassType=ExpType.LoTypeEl.ClassType)
and (GotType.LoTypeEl is TPasProcedureType) then and (GotType.LoTypeEl is TPasProcedureType) then
begin
// procedural types // procedural types
GetIncompatibleProcParamsDesc(TPasProcedureType(GotType.LoTypeEl), GetIncompatibleProcParamsDesc(TPasProcedureType(GotType.LoTypeEl),
TPasProcedureType(ExpType.LoTypeEl),GotDesc,ExpDesc) TPasProcedureType(ExpType.LoTypeEl),GotDesc,ExpDesc);
else if GotDesc<>ExpDesc then
begin exit;
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;
end; 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 end
else else
begin begin
GotDesc:=GetResolverResultDescription(GotType,true); GotDesc:=GetResolverResultDescription(GotType,true);
ExpDesc:=GetResolverResultDescription(ExpType,true); ExpDesc:=GetResolverResultDescription(ExpType,true);
if GotDesc=ExpDesc then if GotDesc<>ExpDesc then
begin exit;
GotDesc:=GetResolverResultDescription(GotType,false); GotDesc:=GetResolverResultDescription(GotType,false);
ExpDesc:=GetResolverResultDescription(ExpType,false); ExpDesc:=GetResolverResultDescription(ExpType,false);
end;
end; end;
end; end;
procedure TPasResolver.GetIncompatibleTypeDesc(const GotType, procedure TPasResolver.GetIncompatibleTypeDesc(const GotType,
ExpType: TPasType; out GotDesc, ExpDesc: String); ExpType: TPasType; out GotDesc, ExpDesc: String);
var
GotLoType, ExpLoType: TPasType;
begin 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); GotDesc:=GetTypeDescription(GotType);
ExpDesc:=GetTypeDescription(ExpType); ExpDesc:=GetTypeDescription(ExpType);
if GotDesc<>ExpDesc then exit; if GotDesc<>ExpDesc then exit;

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

@ -853,6 +853,7 @@ type
Procedure TestAssignProcToFunctionFail; Procedure TestAssignProcToFunctionFail;
Procedure TestAssignProcWrongArgsFail; Procedure TestAssignProcWrongArgsFail;
Procedure TestAssignProcWrongArgAccessFail; Procedure TestAssignProcWrongArgAccessFail;
Procedure TestProcType_SameSignatureObjFPC; // ToDo
Procedure TestProcType_AssignNestedProcFail; Procedure TestProcType_AssignNestedProcFail;
Procedure TestArrayOfProc; Procedure TestArrayOfProc;
Procedure TestProcType_Assigned; Procedure TestProcType_Assigned;
@ -15630,6 +15631,26 @@ begin
nIncompatibleTypeArgNo); nIncompatibleTypeArgNo);
end; 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; procedure TTestResolver.TestProcType_AssignNestedProcFail;
begin begin
StartProgram(false); StartProgram(false);