* fixed assigning an interface to a property after better property

checks

git-svn-id: trunk@7484 -
This commit is contained in:
Jonas Maebe 2007-05-27 10:25:46 +00:00
parent 17bc78aa65
commit fa5e232055
3 changed files with 61 additions and 0 deletions

1
.gitattributes vendored
View File

@ -6855,6 +6855,7 @@ tests/test/tinterface1.pp svneol=native#text/plain
tests/test/tinterface2.pp svneol=native#text/plain
tests/test/tinterface3.pp svneol=native#text/plain
tests/test/tinterface4.pp svneol=native#text/plain
tests/test/tinterface5.pp svneol=native#text/plain
tests/test/tinterrupt.pp svneol=native#text/plain
tests/test/tintfdef.pp svneol=native#text/plain
tests/test/tintuint.pp svneol=native#text/plain

View File

@ -649,6 +649,9 @@ implementation
{ call helpers for interface }
if is_interfacecom(left.resultdef) then
begin
{ remove property flag to avoid errors, see comments for }
{ tf_winlikewidestring assignments below }
exclude(left.flags,nf_isproperty);
if right.resultdef.is_related(left.resultdef) then
begin
hp:=

57
tests/test/tinterface5.pp Normal file
View File

@ -0,0 +1,57 @@
{ %VERSION=1.1 }
{ %SKIPTARGET=macos }
{ On macos it crashes when run.}
{$mode objfpc}
type
IInterface = interface(IUnknown)
procedure mydo;
end;
TMyClass = class(TInterfacedObject, IInterface)
procedure mydo;virtual;
end;
TMyClass2 = class(TMyClass)
i : integer;
end;
TMyClass3 = class
private
fi: IInterface;
public
property intf: IInterface read fi write fi;
end;
var
l : longint;
procedure tmyclass.mydo;
begin
l:=1;
end;
var
c: TMyClass;
c2 : TMyClass;
c3 : TMyClass3;
begin
c := TMyClass.Create;
c3 := TMyClass3.Create;
c3.intf := c;
l:=0;
c3.intf.mydo;
if l<>1 then
halt(1);
c2 := TMyClass2.Create;
c3.intf := c2;
l:=0;
c3.intf.mydo;
if l<>1 then
halt(1);
c3.free;
end.