* patch by Sergei Gorelkin, fixes several issues with implements, resolves #15209

git-svn-id: trunk@14466 -

.gitattributes

@@ -8873,6 +8873,7 @@ tests/test/tclassinfo1.pp svneol=native#text/pascal
 tests/test/tclrprop.pp svneol=native#text/plain
 tests/test/tcmp.pp svneol=native#text/plain
 tests/test/tcmp0.pp svneol=native#text/plain
+tests/test/tdel1.pp svneol=native#text/plain
 tests/test/tendian1.pp svneol=native#text/plain
 tests/test/tenum1.pp svneol=native#text/plain
 tests/test/tenum2.pp svneol=native#text/plain

compiler/ncnv.pas

@@ -2703,26 +2703,34 @@ implementation
                    etStandard:
                      { handle in pass 2 }
                      ;
-                   etFieldValue:
+                   etFieldValue, etFieldValueClass:
                      if is_interface(tobjectdef(resultdef)) then
                        begin
                          result:=left;
                          propaccesslist_to_node(result,tpropertysym(implintf.implementsgetter).owner,tpropertysym(implintf.implementsgetter).propaccesslist[palt_read]);
+                         { this ensures proper refcounting when field is of class type }
+                         if not is_interface(result.resultdef) then
+                           inserttypeconv(result, resultdef);
                          left:=nil;
                        end
                      else
                        begin
                          internalerror(200802213);
                        end;
-                   etStaticMethodResult,
-                   etVirtualMethodResult:
+                   etStaticMethodResult, etStaticMethodClass,
+                   etVirtualMethodResult, etVirtualMethodClass:
                      if is_interface(tobjectdef(resultdef)) then
                        begin
+                         { TODO: generating a call to TObject.GetInterface instead could yield
+                           smaller code size. OTOH, refcounting gotchas are possible that way. }
                          { constructor create(l:tnode; v : tprocsym;st : TSymtable; mp: tnode; callflags:tcallnodeflags); }
                          result:=ccallnode.create(nil,tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym),
                            tprocsym(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym).owner,
                            left,[]);
                          addsymref(tpropertysym(implintf.implementsgetter).propaccesslist[palt_read].firstsym^.sym);
+                         { if it is a class, process it further in a similar way }
+                         if not is_interface(result.resultdef) then
+                           inserttypeconv(result, resultdef);
                          left:=nil;
                        end
                      else if is_class(tobjectdef(resultdef)) then

compiler/nobj.pas

@@ -1236,6 +1236,7 @@ implementation
         iidlabel,
         guidlabel : tasmlabel;
         i: longint;
+        pd: tprocdef;
       begin
         { GUID }
         if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then
@@ -1263,12 +1264,19 @@ 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,
+          etFieldValue, etFieldValueClass,
           etStandard:
             current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset));
-          etVirtualMethodResult,
-          etStaticMethodResult:
-            current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(0));
+          etStaticMethodResult, etStaticMethodClass:
+            current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(
+              tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef).mangledname,
+              0
+            ));
+          etVirtualMethodResult, etVirtualMethodClass:
+            begin
+              pd := tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef);
+              current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(pd._class.vmtmethodoffset(pd.extnumber)));
+            end;
           else
             internalerror(200802162);
         end;

compiler/pdecvar.pas

@@ -764,6 +764,14 @@ implementation
                    else
                      internalerror(200802161);
                  end;
+                 if not is_interface(p.propdef) then
+                   case ImplIntf.IType of
+                     etVirtualMethodResult: ImplIntf.IType := etVirtualMethodClass;
+                     etStaticMethodResult:  ImplIntf.IType := etStaticMethodClass;
+                     etFieldValue:          ImplIntf.IType := etFieldValueClass;
+                   else
+                     internalerror(200912101);
+                   end;
                end
              else
                message1(parser_e_implements_uses_non_implemented_interface,def.GetTypeName);

compiler/symconst.pas

@@ -315,7 +315,10 @@ type
   tinterfaceentrytype = (etStandard,
     etVirtualMethodResult,
     etStaticMethodResult,
-    etFieldValue
+    etFieldValue,
+    etVirtualMethodClass,
+    etStaticMethodClass,
+    etFieldValueClass
   );
 
   { options for objects and classes }

rtl/inc/objpas.inc

@@ -606,53 +606,94 @@
             (PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
         end;
 
-      function getinterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; Corba: Boolean; out obj): boolean;
+      // Use of managed types should be avoided here; implicit _Addref/_Release
+      // will end up in unpredictable behaviour if called on CORBA interfaces.
+      type
+        TInterfaceGetter = procedure(out Obj) of object;
+        TClassGetter = function: TObject of object;
+
+      function getinterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
         var
-          Getter: function: IInterface of object;
+          Getter: TMethod;
         begin
           Pointer(Obj) := nil;
+          Getter.Data := Instance;
           if Assigned(IEntry) and Assigned(Instance) then
           begin
             case IEntry^.IType of
               etStandard:
+                  Pointer(Obj) := Pbyte(instance)+IEntry^.IOffset;
+              etFieldValue, etFieldValueClass:
+                  Pointer(obj) := PPointer(Pbyte(Instance)+IEntry^.IOffset)^;
+              etVirtualMethodResult:
                 begin
-                  //writeln('Doing etStandard cast of ', TObject(Instance).classname(), ' with self = ', ptruint(Instance), ' and offset = ', IEntry^.IOffset);
-                  Pbyte(Obj):=Pbyte(instance)+IEntry^.IOffset;
+                  // IOffset is relative to the VMT, not to instance.
+                  Getter.code := ppointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
+                  TInterfaceGetter(Getter)(obj);
                 end;
-              etFieldValue:
+              etVirtualMethodClass:
                 begin
-                  // writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
-                  Pointer(obj) := PPointer(Pbyte(Instance)+IEntry^.IOffset)^;
+                  // IOffset is relative to the VMT, not to instance.
+                  Getter.code := ppointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
+                  TObject(obj) := TClassGetter(Getter)();
                 end;
-              etVirtualMethodResult:
+              etStaticMethodResult:
                 begin
-                  //writeln('Doing etVirtualMethodResult cast of ', TObject(Instance).classname());
-                  TMethod(Getter).data := Instance;
-                  TMethod(Getter).code := ppointer(Pbyte(Instance) + IEntry^.IOffset)^;
-                  Pointer(obj) := Pointer(Getter());
+                  Getter.code := pointer(IEntry^.IOffset);
+                  TInterfaceGetter(Getter)(obj);
                 end;
-              etStaticMethodResult:
+              etStaticMethodClass:
                 begin
-                  //writeln('Doing etStaticMethodResult cast of ', TObject(Instance).classname());
-                  TMethod(Getter).data := Instance;
-                  TMethod(Getter).code := pointer(IEntry^.IOffset);
-                  Pointer(obj) := Pointer(Getter());
+                  Getter.code := Pointer(IEntry^.IOffset);
+                  TObject(obj) := TClassGetter(Getter)();
                 end;
             end;
           end;
           result := assigned(pointer(obj));
-          if result and not Corba then
-            IInterface(obj)._AddRef;
         end;
 
       function TObject.getinterface(const iid : tguid;out obj) : boolean;
-        begin
-          Result := getinterfacebyentry(self, getinterfaceentry(iid), false, obj);
+        var
+          IEntry: PInterfaceEntry;
+          Instance: TObject;
+        begin
+          Instance := self;
+          repeat
+            IEntry := Instance.getinterfaceentry(iid);
+            result := getinterfacebyentry(Instance, IEntry, obj);
+
+            if (not result) or
+              (IEntry^.IType in [etStandard, etFieldValue,
+               etStaticMethodResult, etVirtualMethodResult]) then
+              Break;
+            { if interface is implemented by a class-type property or field,
+              continue search }
+            Instance := TObject(obj);
+          until False;
+          { Getter function will normally AddRef, so adding another reference here
+            will cause memleak.  }
+          if result and (IEntry^.IType in [etStandard, etFieldValue]) then
+            IInterface(obj)._AddRef;
         end;
 
       function TObject.getinterfacebystr(const iidstr : shortstring;out obj) : boolean;
-        begin
-          Result := getinterfacebyentry(self, getinterfaceentrybystr(iidstr), true, obj);
+        var
+          IEntry: PInterfaceEntry;
+          Instance: TObject;
+        begin
+          Instance := self;
+          repeat
+            IEntry := Instance.getinterfaceentrybystr(iidstr);
+            result := getinterfacebyentry(Instance, IEntry, obj);
+
+            if (not result) or
+              (IEntry^.IType in [etStandard, etFieldValue,
+               etStaticMethodResult, etVirtualMethodResult]) then
+              Break;
+            { if interface is implemented by a class-type property or field,
+              continue search }
+            Instance := TObject(obj);
+          until False;
         end;
 
       function TObject.getinterface(const iidstr : shortstring;out obj) : boolean;

rtl/inc/objpash.inc

@@ -151,7 +151,14 @@
        end;
 
        // This enumerate is found both in the rtl and compiler. Do not change the order of the fields.
-       tinterfaceentrytype = (etStandard, etVirtualMethodResult, etStaticMethodResult, etFieldValue);
+       tinterfaceentrytype = (etStandard,
+         etVirtualMethodResult,
+         etStaticMethodResult,
+         etFieldValue, 
+         etVirtualMethodClass,
+         etStaticMethodClass,
+         etFieldValueClass           
+       );
 
        pinterfaceentry = ^tinterfaceentry;
        tinterfaceentry = record

tests/test/tdel1.pp

@@ -0,0 +1,121 @@
+{%OPT=-gh}
+program td;
+{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
+{ A test for correct refcounting when using different methods of casting
+  object to delegated COM interface. The requirement is no memleaks.
+  Delphi output: 3, 4, 3, 3, 3, 3
+  FPC output:    3, 4, 4, 4, 3, 3
+ }
+
+const
+  STestInterface = '{3FB19775-F5FA-464C-B10C-D8137D742088}';
+
+type
+  ITest = interface[STestInterface]
+    procedure DoSomething;
+  end;
+  
+  TImpl=class(TInterfacedObject,ITest)
+    procedure DoSomething;
+  end;
+
+  TC1=class(TInterfacedObject,ITest)
+  private
+    FImpl: ITest;
+  public
+    constructor Create;
+    property impl: ITest read FImpl implements ITest;
+  end;
+
+  TC2=class(TInterfacedObject,ITest)
+  private
+    FImpl: ITest;
+    function GetImpl: ITest;
+  public
+    constructor Create;
+    property impl: ITest read GetImpl implements ITest;
+  end;
+
+procedure TImpl.DoSomething;
+begin
+  writeln('Doing something');
+end;
+
+function TC2.GetImpl: ITest;
+begin
+  result:=FImpl;
+end;
+
+constructor TC1.Create;
+begin
+  FImpl := TImpl.Create;
+end;
+
+constructor TC2.Create;
+begin
+  FImpl := TImpl.Create;
+end;
+
+var
+  C1: TC1;
+  C2: TC2;
+  I: ITest;
+  ref: Integer;
+
+begin
+  C1 := TC1.Create;
+  C2 := TC2.Create;
+  writeln('Testing typecasting...');
+  
+  I := ITest(C1);
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by field, refcount=', ref);
+  
+  I := ITest(C2);
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by function, refcount=', ref);
+  {clean up}
+  I := nil;
+  C1.Free;
+  C2.Free;
+  
+  writeln('Testing ''as'' operator...');
+  C1 := TC1.Create;
+  C2 := TC2.Create;
+  
+  I := C1 as ITest;
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by field, refcount=', ref);
+  
+  I := C2 as ITest;
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by function, refcount=', ref);
+  {clean up}
+  I := nil;
+  C1.Free;
+  C2.Free;
+
+  writeln('Testing GetInteface()...');
+  C1 := TC1.Create;
+  C2 := TC2.Create;
+  
+  C1.GetInterface(ITest, I);
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by field, refcount=', ref);
+  
+  C2.GetInterface(ITest, I);
+  ref := I._Addref;
+  I._Release;
+  writeln('When delegating by function, refcount=', ref);
+
+  {clean up}
+  I := nil;
+  C1.Free;
+  C2.Free;
+  
+end.