* several small bugs in the handling of implements fixed, resolves #14418

git-svn-id: trunk@13615 -

.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

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));

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;

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 }

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

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.
+