From e8dff46f8e74f97041f4fe7719f73c35e26298f2 Mon Sep 17 00:00:00 2001 From: florian Date: Sun, 30 Aug 2009 08:01:10 +0000 Subject: [PATCH] * several small bugs in the handling of implements fixed, resolves #14418 git-svn-id: trunk@13615 - --- .gitattributes | 1 + compiler/nobj.pas | 8 ++-- compiler/pdecvar.pas | 7 +++- compiler/symdef.pas | 4 +- rtl/inc/objpas.inc | 4 +- tests/webtbs/tw14418.pp | 88 +++++++++++++++++++++++++++++++++++++++++ 6 files changed, 103 insertions(+), 9 deletions(-) create mode 100644 tests/webtbs/tw14418.pp diff --git a/.gitattributes b/.gitattributes index abb467f2f1..b508a07e73 100644 --- a/.gitattributes +++ b/.gitattributes @@ -9223,6 +9223,7 @@ tests/webtbs/tw14307.pp svneol=native#text/plain tests/webtbs/tw1433.pp svneol=native#text/plain tests/webtbs/tw14363.pp svneol=native#text/plain tests/webtbs/tw14403.pp svneol=native#text/plain +tests/webtbs/tw14418.pp svneol=native#text/plain tests/webtbs/tw1445.pp svneol=native#text/plain tests/webtbs/tw1450.pp svneol=native#text/plain tests/webtbs/tw1451.pp svneol=native#text/plain diff --git a/compiler/nobj.pas b/compiler/nobj.pas index 79ce7db8a5..36a1305ef2 100644 --- a/compiler/nobj.pas +++ b/compiler/nobj.pas @@ -518,8 +518,8 @@ implementation for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); - { if it implements itself } - if ImplIntf.VtblImplIntf=ImplIntf then + { if it implements itself and if it's not implemented by delegation } + if (ImplIntf.VtblImplIntf=ImplIntf) and (ImplIntf.IType=etStandard) then begin { allocate a pointer in the object memory } with tObjectSymtable(_class.symtable) do @@ -536,7 +536,7 @@ implementation begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); if ImplIntf.VtblImplIntf<>ImplIntf then - ImplIntf.Ioffset:=ImplIntf.VtblImplIntf.Ioffset; + ImplIntf.IOffset:=ImplIntf.VtblImplIntf.IOffset; end; end; @@ -1106,9 +1106,9 @@ implementation current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0)); { IOffset field } case AImplIntf.VtblImplIntf.IType of + etFieldValue, etStandard: current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset)); - etFieldValue, etVirtualMethodResult, etStaticMethodResult: current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(0)); diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 958e0bf2c8..b8d17543d2 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -740,6 +740,7 @@ implementation if found then begin ImplIntf.ImplementsGetter:=p; + ImplIntf.VtblImplIntf:=ImplIntf; case p.propaccesslist[palt_read].firstsym^.sym.typ of procsym : begin @@ -749,7 +750,11 @@ implementation ImplIntf.IType:=etStaticMethodResult; end; fieldvarsym : - ImplIntf.IType:=etFieldValue; + begin + ImplIntf.IType:=etFieldValue; + { this must be done more sophisticated, here is also probably the wrong place } + ImplIntf.IOffset:=tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset; + end else internalerror(200802161); end; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index c51fccc3ab..39af4d4d2b 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -2071,7 +2071,7 @@ implementation begin result:=true; end; - + procedure tclassrefdef.reset; begin @@ -4397,7 +4397,7 @@ implementation begin result:=false; { interfaces being implemented through delegation are not mergable (FK) } - if (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) then + if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) then exit; weight:=0; { empty interface is mergeable } diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index c6c3d3f03d..41539644db 100644 --- a/rtl/inc/objpas.inc +++ b/rtl/inc/objpas.inc @@ -619,8 +619,8 @@ end; etFieldValue: begin - //writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset); - Pointer(obj) := ppointer(Pbyte(Instance)+IEntry^.IOffset)^; + // writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset); + Pointer(obj) := PPointer(Pbyte(Instance)+IEntry^.IOffset)^; end; etVirtualMethodResult: begin diff --git a/tests/webtbs/tw14418.pp b/tests/webtbs/tw14418.pp new file mode 100644 index 0000000000..77e30362e9 --- /dev/null +++ b/tests/webtbs/tw14418.pp @@ -0,0 +1,88 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes + { you can add units after this }; + +type + IIntf1 = interface + ['{87776F0F-8CE0-4881-B969-C76F5A9CA517}'] + procedure M1; + end; + + IIntf2 = interface + ['{923C47DF-0A7E-4698-98B8-45175306CDF2}'] + procedure M2; + end; + + { TObjIntf2 } + + TObjIntf2 = class(TInterfacedObject, IIntf2) + procedure M2; + end; + + { TObj } + + TObj = class(TInterfacedObject, IIntf1, IIntf2) + private + FObjIntf2:IIntf2; + public + constructor Create; + + procedure M1; + + //when implementing IIntf2 using delegation, + //TObj1.M1 is called instead of TObjIntf2 + property I2:IIntf2 read FObjIntf2 implements IIntf2; + + //when implementing M2 directly it works right. + //procedure M2; + end; + +{ TObjIntf2 } + +procedure TObjIntf2.M2; +begin + Writeln('TObjIntf2.M2 called'); +end; + +{ TObj } + +constructor TObj.Create; +begin + FObjIntf2:=TObjIntf2.Create; +end; + +procedure TObj.M1; +begin + Writeln('TObj.M1 called'); +end; + +{ +procedure TObj.M2; +begin + Writeln('TObj.M2 called'); +end; +} + +var O:TObj; + i1:IIntf1; + i2:IIntf2; +begin + O:=TObj.Create; + i1:=O; + + //all tries are unsuccessful + //i2:=O as IIntf2; + //(O as IIntf1).QueryInterface(IIntf2, i2); + i1.QueryInterface(IIntf2, i2); + + //still calls TObj1.M1 + i2.M2; +end. +