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

* fixed loading the address of class methods (mantis #9139)

Browse Source 
git-svn-id: trunk@7789 -
This commit is contained in:
Jonas Maebe 2007-06-24 12:11:08 +00:00
parent cd2880cbbd
commit 62b9198b55
4 changed files with 157 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -8313,6 +8313,8 @@ tests/webtbs/tw9107.pp svneol=native#text/plain
tests/webtbs/tw9108.pp svneol=native#text/plain
tests/webtbs/tw9113.pp svneol=native#text/plain
tests/webtbs/tw9128.pp svneol=native#text/plain
tests/webtbs/tw9139.pp svneol=native#text/plain
tests/webtbs/tw9139a.pp svneol=native#text/plain
tests/webtbs/ub1873.pp svneol=native#text/plain
tests/webtbs/ub1883.pp svneol=native#text/plain
tests/webtbs/uw0555.pp svneol=native#text/plain

18
compiler/ncgld.pas
View File

@ -413,7 +413,7 @@ implementation
tg.GetTemp(current_asmdata.CurrAsmList,2*sizeof(aint),tt_normal,location.reference);
secondpass(left);
{ load class instance address }
{ load class instance/classrefdef address }
if left.location.loc=LOC_CONSTANT then
location_force_reg(current_asmdata.CurrAsmList,left.location,OS_ADDR,false);
case left.location.loc of
@ -429,7 +429,7 @@ implementation
LOC_REFERENCE:
begin
hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
if is_class_or_interface(left.resultdef) then
if not is_object(left.resultdef) then
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,left.location.reference,hregister)
else
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,hregister);
@ -439,7 +439,7 @@ implementation
internalerror(200610311);
end;
{ store the class instance address }
{ store the class instance or classredef address }
href:=location.reference;
inc(href.offset,sizeof(aint));
cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,hregister,href);
@ -448,10 +448,14 @@ implementation
if (po_virtualmethod in procdef.procoptions) and
not(nf_inherited in flags) then
begin
{ load vmt pointer }
reference_reset_base(href,hregister,0);
hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
{ a classrefdef already points to the VMT }
if (left.resultdef.typ<>classrefdef) then
begin
{ load vmt pointer }
reference_reset_base(href,hregister,0);
hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
end;
{ load method address }
reference_reset_base(href,hregister,procdef._class.vmtmethodoffset(procdef.extnumber));
hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);

72
tests/webtbs/tw9139.pp Normal file
View File

@ -0,0 +1,72 @@
{$mode objfpc}{$H+}
{.$define second_test}
type
TTestClass = class of TTestBase;
TTestBase = class(TObject)
public
class function ClassMetadataStr: string;
class function InternalMetadataStr: string; virtual;
end;
TTestImpl = class(TTestBase)
public
class function InternalMetadataStr: string; override;
end;
class function TTestBase.ClassMetadataStr: string;
var
VMetadataMethod, VParentMetadataMethod: function: string of object;
{$ifdef second_test}
VClass: TTestClass;
{$endif}
begin
if Self <> TTestBase then
begin
writeln('pass 1');
VMetadataMethod := @InternalMetadataStr;
writeln('pass 2');
{$ifndef second_test}
VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
{$else}
VClass := TTestClass(ClassParent);
writeln('pass 2.1');
VParentMetadataMethod := @VClass.InternalMetadataStr;
{$endif}
writeln('pass 3');
if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
begin
Result := VParentMetadataMethod();
writeln('result: ',result);
if Result<>'parent meth' then
halt(1);
end
else
halt(2);
writeln('pass 4');
end else
Result := 'base result';
end;
class function TTestBase.InternalMetadataStr: string;
begin
Result := 'parent meth';
end;
class function TTestImpl.InternalMetadataStr: string;
begin
Result := 'some stuff';
end;
var
VTestClass: TTestClass;
begin
VTestClass := TTestBase;
writeln('TTestBase result:');
writeln(VTestClass.ClassMetadataStr);
writeln;
VTestClass := TTestImpl;
writeln('TTestImpl result:');
writeln(VTestClass.ClassMetadataStr);
end.

72
tests/webtbs/tw9139a.pp Normal file
View File

@ -0,0 +1,72 @@
{$mode objfpc}{$H+}
{$define second_test}
type
TTestClass = class of TTestBase;
TTestBase = class(TObject)
public
class function ClassMetadataStr: string;
class function InternalMetadataStr: string; virtual;
end;
TTestImpl = class(TTestBase)
public
class function InternalMetadataStr: string; override;
end;
class function TTestBase.ClassMetadataStr: string;
var
VMetadataMethod, VParentMetadataMethod: function: string of object;
{$ifdef second_test}
VClass: TTestClass;
{$endif}
begin
if Self <> TTestBase then
begin
writeln('pass 1');
VMetadataMethod := @InternalMetadataStr;
writeln('pass 2');
{$ifndef second_test}
VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
{$else}
VClass := TTestClass(ClassParent);
writeln('pass 2.1');
VParentMetadataMethod := @VClass.InternalMetadataStr;
{$endif}
writeln('pass 3');
if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
begin
Result := VParentMetadataMethod();
writeln('result: ',result);
if Result<>'parent meth' then
halt(1);
end
else
halt(2);
writeln('pass 4');
end else
Result := 'base result';
end;
class function TTestBase.InternalMetadataStr: string;
begin
Result := 'parent meth';
end;
class function TTestImpl.InternalMetadataStr: string;
begin
Result := 'some stuff';
end;
var
VTestClass: TTestClass;
begin
VTestClass := TTestBase;
writeln('TTestBase result:');
writeln(VTestClass.ClassMetadataStr);
writeln;
VTestClass := TTestImpl;
writeln('TTestImpl result:');
writeln(VTestClass.ClassMetadataStr);
end.