From 62b9198b5536e223e39570e3ac2bae8be05bf9ab Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 24 Jun 2007 12:11:08 +0000 Subject: [PATCH] * fixed loading the address of class methods (mantis #9139) git-svn-id: trunk@7789 - --- .gitattributes | 2 ++ compiler/ncgld.pas | 18 +++++++---- tests/webtbs/tw9139.pp | 72 +++++++++++++++++++++++++++++++++++++++++ tests/webtbs/tw9139a.pp | 72 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 157 insertions(+), 7 deletions(-) create mode 100644 tests/webtbs/tw9139.pp create mode 100644 tests/webtbs/tw9139a.pp diff --git a/.gitattributes b/.gitattributes index 5a953275ca..a84c4b86e5 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/compiler/ncgld.pas b/compiler/ncgld.pas index ac377d263b..e92cdaf95b 100644 --- a/compiler/ncgld.pas +++ b/compiler/ncgld.pas @@ -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); diff --git a/tests/webtbs/tw9139.pp b/tests/webtbs/tw9139.pp new file mode 100644 index 0000000000..1e82e5864e --- /dev/null +++ b/tests/webtbs/tw9139.pp @@ -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. diff --git a/tests/webtbs/tw9139a.pp b/tests/webtbs/tw9139a.pp new file mode 100644 index 0000000000..24eedfed1a --- /dev/null +++ b/tests/webtbs/tw9139a.pp @@ -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.