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

fcl-passrc: nicer error message when calling property proc var with wrong args

Browse Source 
git-svn-id: trunk@35735 -
This commit is contained in:
Mattias Gaertner 2017-04-04 22:59:33 +00:00
parent 321876252b
commit 2afaeb60de
2 changed files with 55 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4953,6 +4953,14 @@ begin
else if FindCallData.Found is TPasType then else if FindCallData.Found is TPasType then
// Note: check TPasType after TPasUnresolvedSymbolRef // Note: check TPasType after TPasUnresolvedSymbolRef
CheckTypeCast(TPasType(FindCallData.Found),Params,true) CheckTypeCast(TPasType(FindCallData.Found),Params,true)
else if FindCallData.Found is TPasVariable then
begin
TypeEl:=ResolveAliasType(TPasVariable(FindCallData.Found).VarType);
if TypeEl is TPasProcedureType then
CheckCallProcCompatibility(TPasProcedureType(TypeEl),Params,true)
else
RaiseMsg(20170405003522,nIllegalQualifier,sIllegalQualifier,['('],Params);
end
else else
RaiseNotYetImplemented(20161003134755,FindCallData.Found); RaiseNotYetImplemented(20161003134755,FindCallData.Found);
end; end;

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

@ -518,6 +518,8 @@ type
Procedure TestProcType_AllowNested; Procedure TestProcType_AllowNested;
Procedure TestProcType_AllowNestedOfObject; Procedure TestProcType_AllowNestedOfObject;
Procedure TestProcType_AsArgOtherUnit; Procedure TestProcType_AsArgOtherUnit;
Procedure TestProcType_Property;
Procedure TestProcType_PropertyCallWrongArgFail;
end; end;
function LinesToStr(Args: array of const): string; function LinesToStr(Args: array of const): string;
@ -8360,6 +8362,51 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestProcType_Property;
begin
StartProgram(false);
Add('type');
Add(' TObject = class end;');
Add(' TNotifyEvent = procedure(Sender: TObject) of object;');
Add(' TControl = class');
Add(' FOnClick: TNotifyEvent;');
Add(' property OnClick: TNotifyEvent read FOnClick write FOnClick;');
Add(' procedure Click(Sender: TObject);');
Add(' end;');
Add('procedure TControl.Click(Sender: TObject);');
Add('begin');
Add(' if Assigned(OnClick) then ;');
Add(' OnClick:=@Click');
Add(' OnClick(Sender);');
Add(' Self.OnClick(Sender);');
Add(' with Self do OnClick(Sender);');
Add('end;');
Add('var Btn: TControl;');
Add('begin');
Add(' if Assigned(Btn.OnClick) then ;');
Add(' Btn.OnClick(Btn);');
Add(' Btn.OnClick(Btn);');
Add(' with Btn do OnClick(Btn);');
ParseProgram;
end;
procedure TTestResolver.TestProcType_PropertyCallWrongArgFail;
begin
StartProgram(false);
Add('type');
Add(' TObject = class end;');
Add(' TNotifyEvent = procedure(Sender: TObject) of object;');
Add(' TControl = class');
Add(' FOnClick: TNotifyEvent;');
Add(' property OnClick: TNotifyEvent read FOnClick write FOnClick;');
Add(' end;');
Add('var Btn: TControl;');
Add('begin');
Add(' Btn.OnClick(3);');
CheckResolverException('Incompatible type arg no. 1: Got "Longint", expected "TObject"',
nIncompatibleTypeArgNo);
end;
initialization initialization
RegisterTests([TTestResolver]); RegisterTests([TTestResolver]);