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

* save/restore itype and implementsgetter fields of timplementedinterface

Browse Source 
to/from ppu, because it can be required while resolving type casts
    (mantis #22741)

git-svn-id: trunk@22266 -
This commit is contained in:
Jonas Maebe 2012-08-29 16:07:55 +00:00
parent c501e6db5f
commit ad054831bb
6 changed files with 148 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -12817,6 +12817,7 @@ tests/webtbs/tw2268.pp svneol=native#text/plain
tests/webtbs/tw2269.pp svneol=native#text/plain
tests/webtbs/tw22705.pp svneol=native#text/plain
tests/webtbs/tw2274.pp svneol=native#text/plain
tests/webtbs/tw22741.pp svneol=native#text/plain
tests/webtbs/tw22744.pp svneol=native#text/pascal
tests/webtbs/tw2277.pp svneol=native#text/plain
tests/webtbs/tw2280.pp svneol=native#text/plain
@ -13609,6 +13610,8 @@ tests/webtbs/uw21808b.pp svneol=native#text/plain
tests/webtbs/uw2266a.inc svneol=native#text/plain
tests/webtbs/uw2266b.pas svneol=native#text/plain
tests/webtbs/uw2269.inc svneol=native#text/plain
tests/webtbs/uw22741a.pp svneol=native#text/plain
tests/webtbs/uw22741b.pp svneol=native#text/plain
tests/webtbs/uw2364.pp svneol=native#text/plain
tests/webtbs/uw2706a.pp svneol=native#text/plain
tests/webtbs/uw2706b.pp svneol=native#text/plain

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 152;
CurrentPPUVersion = 153;
{ buffer sizes }
maxentrysize = 1024;

18
compiler/symdef.pas
View File

@ -242,9 +242,10 @@ interface
NameMappings : TFPHashList;
ProcDefs : TFPObjectList;
ImplementsGetter : tsym;
ImplementsGetterDeref : tderef;
ImplementsField : tsym;
constructor create(aintf: tobjectdef);
constructor create_deref(d:tderef);
constructor create_deref(intfd,getterd:tderef);
destructor destroy; override;
function getcopy:TImplementedInterface;
procedure buildderef;
@ -5189,7 +5190,7 @@ implementation
var
i,
implintfcount : longint;
d : tderef;
d, getterd : tderef;
ImplIntf : TImplementedInterface;
vmtentry : pvmtentry;
begin
@ -5240,8 +5241,10 @@ implementation
for i:=0 to implintfcount-1 do
begin
ppufile.getderef(d);
ImplIntf:=TImplementedInterface.Create_deref(d);
ppufile.getderef(getterd);
ImplIntf:=TImplementedInterface.Create_deref(d,getterd);
ImplIntf.IOffset:=ppufile.getlongint;
byte(ImplIntf.IType):=ppufile.getbyte;
ImplementedInterfaces.Add(ImplIntf);
end;
end
@ -5425,7 +5428,9 @@ implementation
begin
ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
ppufile.putderef(ImplIntf.intfdefderef);
ppufile.putderef(ImplIntf.ImplementsGetterDeref);
ppufile.putlongint(ImplIntf.Ioffset);
ppufile.putbyte(byte(ImplIntf.IType));
end;
end;
@ -6275,11 +6280,12 @@ implementation
end;
constructor TImplementedInterface.create_deref(d:tderef);
constructor TImplementedInterface.create_deref(intfd,getterd:tderef);
begin
inherited create;
intfdef:=nil;
intfdefderef:=d;
intfdefderef:=intfd;
ImplementsGetterDeref:=getterd;
IOffset:=-1;
IType:=etStandard;
NameMappings:=nil;
@ -6314,12 +6320,14 @@ implementation
procedure TImplementedInterface.buildderef;
begin
intfdefderef.build(intfdef);
ImplementsGetterDeref.build(ImplementsGetter);
end;
procedure TImplementedInterface.deref;
begin
intfdef:=tobjectdef(intfdefderef.resolve);
ImplementsGetter:=tsym(ImplementsGetterDeref.resolve);
end;

29
tests/webtbs/tw22741.pp Normal file
View File

@ -0,0 +1,29 @@
{ %recompile }
{ %opt=-gh }
program tw22741;
{$mode objfpc}
uses uw22741a;
type
te= class(td)
procedure address(d: td); virtual;
end;
procedure te.address(d: td);
var anIo: iIO;
begin
writeln(d.className);
writeln(nativeuint(iIO(d)));
writeln(nativeuint(iIO(d.fiio)));
anIo:= d;
writeln(nativeuint(anIo));
end;
var
e1, e2: te;
begin
e1:= te.create;
e2:= te.create;
e1.address(e2);
e1.destroy;
e2.destroy;
end.

54
tests/webtbs/uw22741a.pp Normal file
View File

@ -0,0 +1,54 @@
unit uw22741a;
{$mode objfpc}
interface
uses uw22741b;
type
iIO= interface
procedure read;
procedure write;
end;
tc= class(tInterfaceObject, iIO)
procedure read; virtual;
procedure write; virtual;
destructor destroy; override;
end;
type
td= class(tObject, iIO)
ftc: tc;
fiio: iIO;
property io: tc read ftc implements iIO;
constructor create; virtual;
destructor destroy; override;
end;
implementation
procedure tc.read; begin end;
procedure tc.write; begin end;
destructor tc.destroy;
begin
writeln('tc ', nativeuint(self), ' destroyed');
inherited;
end;
constructor td.create;
begin
inherited;
ftc:= tc.create;
fiio:= ftc; // increace reference counter to one
end;
destructor td.destroy;
begin
fiio:= nil; // ftc is automatically destroyed
ftc.free;
writeln('td ', nativeuint(self), ' destroyed');
inherited;
end;
end.

48
tests/webtbs/uw22741b.pp Normal file
View File

@ -0,0 +1,48 @@
unit uw22741b;
{$mode objfpc}
interface
type
iBase = interface
function getSelf: tObject;
end;
tInterfaceObject= class(tObject, iBase)
public
function getSelf: tObject;
function queryInterface({$IFDEF FPC_HAS_CONSTREF}constRef{$ELSE}const{$ENDIF} iid: tGuid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
function _addRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
function _release: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual;
end;
implementation
function tInterfaceObject.getSelf: tObject;
begin
result:= self;
end;
function tInterfaceObject.queryInterface({$IFDEF FPC_HAS_CONSTREF}constRef{$ELSE}const{$ENDIF} iid: tGuid; out obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
if getInterface(iId, obj) then
result:= S_OK
else
result:= longint(E_NOINTERFACE);
end;
function tInterfaceObject._addRef: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= 1;
end;
function tInterfaceObject._release: longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
result:= 1;
end;
end.