mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-15 20:09:20 +02:00
* fix #39902: correctly handle assignment of procvars to properties with a field write accessor
+ added adjusted/extended test
This commit is contained in:
parent
68253e2a73
commit
13fb30c52e
@ -1308,7 +1308,17 @@ implementation
|
|||||||
include(p1.flags,nf_isproperty);
|
include(p1.flags,nf_isproperty);
|
||||||
consume(_ASSIGNMENT);
|
consume(_ASSIGNMENT);
|
||||||
{ read the expression }
|
{ read the expression }
|
||||||
|
if propsym.propdef.typ=procvardef then
|
||||||
|
getprocvardef:=tprocvardef(propsym.propdef)
|
||||||
|
else if is_invokable(propsym.propdef) then
|
||||||
|
getfuncrefdef:=tobjectdef(propsym.propdef);
|
||||||
p2:=comp_expr([ef_accept_equal]);
|
p2:=comp_expr([ef_accept_equal]);
|
||||||
|
if assigned(getprocvardef) then
|
||||||
|
handle_procvar(getprocvardef,p2)
|
||||||
|
else if assigned(getfuncrefdef) then
|
||||||
|
handle_funcref(getfuncrefdef,p2);
|
||||||
|
getprocvardef:=nil;
|
||||||
|
getfuncrefdef:=nil;
|
||||||
p1:=cassignmentnode.create(p1,p2);
|
p1:=cassignmentnode.create(p1,p2);
|
||||||
end
|
end
|
||||||
else
|
else
|
||||||
|
48
tests/webtbs/tw39902a.pp
Normal file
48
tests/webtbs/tw39902a.pp
Normal file
@ -0,0 +1,48 @@
|
|||||||
|
{ %NORUN }
|
||||||
|
|
||||||
|
program tw39902a;
|
||||||
|
|
||||||
|
{$mode delphi}
|
||||||
|
|
||||||
|
uses Classes;
|
||||||
|
|
||||||
|
type TTest = class(TObject)
|
||||||
|
FEvent: TNotifyEvent;
|
||||||
|
procedure SetEvent(aValue: TNotifyEvent);
|
||||||
|
procedure SomeEvent (Sender: NativeInt); overload;
|
||||||
|
procedure SomeEvent (Sender: TObject); overload;
|
||||||
|
property Event1: TNotifyEvent read FEvent write FEvent;
|
||||||
|
property Event2: TNotifyEvent read FEvent write SetEvent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTest.SetEvent(aValue: TNotifyEvent);
|
||||||
|
begin
|
||||||
|
FEvent:=aValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTest.SomeEvent (Sender: TObject);
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TTest.SomeEvent (Sender: NativeInt);
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure Foo(aArg: TNotifyEvent);
|
||||||
|
begin
|
||||||
|
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
x: TTest;
|
||||||
|
//y: TStringList;
|
||||||
|
m: TNotifyEvent;
|
||||||
|
begin
|
||||||
|
x := TTest.Create;
|
||||||
|
//y := TStringList.Create;
|
||||||
|
//y.OnChange := x.SomeEvent;
|
||||||
|
x.Event1 := x.SomeEvent;
|
||||||
|
x.Event2 := x.SomeEvent;
|
||||||
|
m := x.SomeEvent;
|
||||||
|
Foo(x.someEvent);
|
||||||
|
end.
|
Loading…
Reference in New Issue
Block a user