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

* fixed getting address of interface methods after r32414: interfaces are not

Browse Source 
a pointer to a vmt, but a pointer to a pointer to vmt (mantis #29086)
   o also adjusted the llvm type for interfaces accordingly

git-svn-id: trunk@32530 -
This commit is contained in:
Jonas Maebe 2015-11-25 19:28:17 +00:00
parent bfa96171e0
commit 0c4edd2aa9
4 changed files with 78 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -14882,6 +14882,7 @@ tests/webtbs/tw29053.pp svneol=native#text/pascal
tests/webtbs/tw29053b.pp svneol=native#text/pascal
tests/webtbs/tw29064.pp svneol=native#text/plain
tests/webtbs/tw2908.pp svneol=native#text/plain
tests/webtbs/tw29086.pp -text svneol=native#text/plain
tests/webtbs/tw2911.pp svneol=native#text/plain
tests/webtbs/tw2912.pp svneol=native#text/plain
tests/webtbs/tw2913.pp svneol=native#text/plain

4
compiler/llvm/llvmdef.pas
View File

@ -482,10 +482,10 @@ implementation
odt_interfacecorba,
odt_dispinterface:
begin
{ type is a pointer to the vmt }
{ type is a pointer to a pointer to the vmt }
llvmaddencodedtype_intern(tobjectdef(def).vmt_def,flags,encodedstr);
if ([lef_typedecl,lef_noimplicitderef]*flags=[]) then
encodedstr:=encodedstr+'*';
encodedstr:=encodedstr+'**';
end;
odt_interfacecom_function,
odt_interfacecom_property,

26
compiler/ncgld.pas
View File

@ -529,10 +529,8 @@ implementation
current_asmdata.CurrAsmList.Concat(tai_symbol.CreateName('VTREF'+tostr(current_asmdata.NextVTEntryNr)+'_'+procdef._class.vmt_mangledname+'$$'+tostr(vmtoffset div sizeof(pint)),AT_FUNCTION,0));
end;
{$endif vtentry}
{ a classrefdef already points to the VMT, and
so do interfaces }
if (left.resultdef.typ<>classrefdef) and
not is_any_interface_kind(left.resultdef) then
if (left.resultdef.typ=objectdef) and
assigned(tobjectdef(left.resultdef).vmt_field) then
begin
{ vmt pointer is a pointer to the vmt record }
hlcg.reference_reset_base(href,vd,location.registerhi,0,vd.alignment);
@ -541,15 +539,23 @@ implementation
hregister:=hlcg.getaddressregister(current_asmdata.CurrAsmList,vmtdef);
hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,tfieldvarsym(tobjectdef(left.resultdef).vmt_field).vardef,vmtdef,href,hregister);
end
else
else if left.resultdef.typ=classrefdef then
begin
{ classrefdef is a pointer to the vmt already }
hregister:=location.registerhi;
if left.resultdef.typ=classrefdef then
vmtdef:=cpointerdef.getreusable(tobjectdef(tclassrefdef(left.resultdef).pointeddef).vmt_def)
else
vmtdef:=cpointerdef.getreusable(tobjectdef(left.resultdef).vmt_def);
vmtdef:=cpointerdef.getreusable(tobjectdef(tclassrefdef(left.resultdef).pointeddef).vmt_def);
hlcg.g_ptrtypecast_reg(current_asmdata.CurrAsmList,left.resultdef,vmtdef,hregister);
end;
end
else if is_any_interface_kind(left.resultdef) then
begin
{ an interface is a pointer to a pointer to a vmt }
hlcg.reference_reset_base(href,vd,location.registerhi,0,vd.alignment);
vmtdef:=cpointerdef.getreusable(tobjectdef(left.resultdef).vmt_def);
hregister:=hlcg.getaddressregister(current_asmdata.CurrAsmList,vmtdef);
hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,vmtdef,vmtdef,href,hregister);
end
else
internalerror(2015112501);
{ load method address }
vmtentry:=tabstractrecordsymtable(trecorddef(vmtdef.pointeddef).symtable).findfieldbyoffset(
tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber));

59
tests/webtbs/tw29086.pp Executable file
View File

@ -0,0 +1,59 @@
program project1;
{$mode objfpc}{$h+}
type
ITestInt = interface
function GetN(a:Integer):Integer;
function GetX(a:Integer):Integer;
end;
{ TIntTest }
TIntTest = class(TInterfacedObject,ITestInt)
function GetN(a: Integer): Integer;
function GetX(a: Integer): Integer;
end;
TIntTestVal = record
FTestInt : ITestInt;
end;
TIntTestFunc = function(a:Integer):Integer of object;
TIntTestInclude = class
FValue : TIntTestVal;
end;
ttestobj = object
a, b : TIntTestFunc;
end;
var
inttest : TIntTest;
inttestvalinc : TIntTestInclude;
x : ttestobj;
{ TIntTest }
function TIntTest.GetN(a: Integer): Integer;
begin
Result:=a+1;
end;
function TIntTest.GetX(a: Integer): Integer;
begin
Result:=a+2;
end;
begin
inttest:=TIntTest.Create;
inttestvalinc:=TIntTestInclude.Create;
inttestvalinc.FValue.FTestInt:=inttest;
x.a := @inttestvalinc.FValue.FTestInt.GetN;
x.b := @inttestvalinc.FValue.FTestInt.GetX;
writeln(x.a(1));
writeln(x.b(1));
end.