Implementing TImplementedInterface.getcopy to allow copying of interfaced objectcs

It's probably not fully correct(see comment about procdef copy) but
seems good enough ¯\_(ツ)_/¯

compiler/symdef.pas

@@ -443,7 +443,7 @@ interface
          constructor create(aintf: tobjectdef);virtual;
          constructor create_deref(intfd,getterd:tderef);virtual;
          destructor  destroy; override;
-         function  getcopy:TImplementedInterface;
+         function getcopy:TImplementedInterface;
          procedure buildderef;
          procedure deref;
          procedure AddMapping(const origname, newname: string);
@@ -9142,18 +9142,48 @@ implementation
 
 
     function TImplementedInterface.getcopy:TImplementedInterface;
+
+      function stringdup(s:pshortstring):pshortstring;inline;
+        begin
+           getmem(result,ord(s^[0])+1);
+           move(s^[0],result^[0],ord(s^[0])+1);
+        end;
+
+      var
+        i : longint;
       begin
         Result:=TImplementedInterface.Create(nil);
         { 1) the procdefs list will be freed once for each copy
           2) since the procdefs list owns its elements, those will also be freed for each copy
+             Nope: procdefs are owned by their symtable, so no copy necessary
           3) idem for the name mappings
         }
-        { warning: this is completely wrong on so many levels...
-        Move(pointer(self)^,pointer(result)^,InstanceSize);
-        We need to make clean copies of the different fields
-        this is not implemented yet, and thus we generate an internal
-        error instead PM 2011-06-14 }
-        internalerror(2011061401);
+        result.fIOffset:=fIOffset;
+        result.IntfDef:=IntfDef;
+        result.IntfDefDeref.reset;
+        result.IType:=IType;
+        result.VtblImplIntf:=VtblImplIntf;
+        if assigned(NameMappings) then
+          begin
+            result.NameMappings:=TFPHashList.create;
+            for i:=0 to NameMappings.Count-1 do
+              Result.NameMappings.Add(NameMappings.NameOfIndex(i),
+                                      stringdup(pshortstring(NameMappings.Items[i])));
+          end;
+        if assigned(ProcDefs) then
+          begin
+            result.ProcDefs:=TFPObjectList.create(false);
+            { Note: this is probably wrong, because those procdefs are owned by
+              the old objectdef from which we copy, what would be the correct way
+              of doing this is to lookup the equivalent copy in the new owner
+              and reference this instead... But this is complicated so let's try
+              it this way until it blows up ok? }
+            for i:=0 to ProcDefs.Count-1 do
+              Result.ProcDefs.add(tprocdef(procdefs[i]).getcopy);
+          end;
+        result.ImplementsGetter:=ImplementsGetter;
+        result.ImplementsGetterDeref.reset;
+        result.ImplementsField:=ImplementsField;
       end;
 
 {****************************************************************************

tests/test/tinterface10.pp

@@ -0,0 +1,53 @@
+{ %VERSION=1.1 }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  ITest = interface(IUnknown)
+    procedure DoSomething;
+  end;
+
+
+  TMyClass = class(TInterfacedObject, ITest)
+    procedure MyDoSomething;
+    procedure ITest.DoSomething = MyDoSomething;
+  end;
+
+var
+   i : longint;
+
+procedure TMyClass.MyDoSomething;
+begin
+  inc(i);
+end;
+
+
+procedure DoTest(const ATest: ITest);
+begin
+  ATest.DoSomething;
+end;
+
+
+procedure DoTest2(ATest: ITest);
+begin
+  ATest.DoSomething;
+end;
+
+type TMyClassCopy = type TMyClass;
+
+
+var
+  c: ITest;
+begin
+  i:=0;
+  c := TMyClassCopy.Create;
+  DoTest(c);
+  DoTest2(c);
+  if i<>2 then
+    begin
+       writeln('Problem with passing interfaces as parameters');
+       halt(1);
+    end;
+end.

tests/test/tinterface7.pp

@@ -0,0 +1,47 @@
+{ %SKIPTARGET=macos }
+{ On macos it crashes when run.}
+
+{$mode objfpc}
+type
+  IInterface = interface(IUnknown)
+     procedure mydo;
+  end;
+
+  TMyClass = class(TInterfacedObject, IInterface)
+     procedure mydo;virtual;
+  end;
+
+  TMyClass2 = class(TMyClass)
+     i : integer;
+  end;
+
+  TMyClass2Copy = type TMyClass2;
+
+var
+   l : longint;
+
+procedure tmyclass.mydo;
+
+  begin
+     l:=1;
+  end;
+
+var
+  c: TMyClass;
+  i: IInterface;
+  c2 : TMyClass;
+
+begin
+  c := TMyClass.Create;
+  i := c;
+  l:=0;
+  i.mydo;
+  if l<>1 then
+    halt(1);
+  c2 := TMyClass2Copy.Create;
+  i := c2;
+  l:=0;
+  i.mydo;
+  if l<>1 then
+    halt(1);
+end.

tests/test/tinterface8.pp

@@ -0,0 +1,52 @@
+{ %VERSION=1.1 }
+
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  ITest = interface(IUnknown)
+    procedure DoSomething;
+  end;
+
+
+  TMyClass = class(TInterfacedObject, ITest)
+    procedure DoSomething;
+  end;
+
+var
+   i : longint;
+
+procedure TMyClass.DoSomething;
+begin
+  inc(i);
+end;
+
+
+procedure DoTest(const ATest: ITest);
+begin
+  ATest.DoSomething;
+end;
+
+
+procedure DoTest2(ATest: ITest);
+begin
+  ATest.DoSomething;
+end;
+
+type TMyClassCopy = type TMyClass;
+
+
+var
+  c: ITest;
+begin
+  i:=0;
+  c := TMyClassCopy.Create;
+  DoTest(c);
+  DoTest2(c);
+  if i<>2 then
+    begin
+       writeln('Problem with passing interfaces as parameters');
+       halt(1);
+    end;
+end.

tests/test/tinterface9.pp

@@ -0,0 +1,60 @@
+{ %VERSION=1.1 }
+{ %SKIPTARGET=macos }
+{ On macos it crashes when run.}
+
+{$mode objfpc}
+type
+  IInterface = interface(IUnknown)
+     procedure mydo;
+  end;
+
+  TMyClass = class(TInterfacedObject, IInterface)
+     procedure mydo;virtual;
+  end;
+
+  TMyClassCopy = type TMyClass;
+
+  TMyClass2 = class(TMyClassCopy)
+     i : integer;
+  end;
+
+  TMyClass3 = class
+    private
+      fi: IInterface;
+    public
+      property intf: IInterface read fi write fi;
+  end;
+
+
+
+
+var
+   l : longint;
+
+procedure tmyclass.mydo;
+
+  begin
+     l:=1;
+  end;
+
+var
+  c: TMyClassCopy;
+  c2 : TMyClassCopy;
+  c3 : TMyClass3;
+
+begin
+  c := TMyClassCopy.Create;
+  c3 := TMyClass3.Create;
+  c3.intf := c;
+  l:=0;
+  c3.intf.mydo;
+  if l<>1 then
+    halt(1);
+  c2 := TMyClass2.Create;
+  c3.intf := c2;
+  l:=0;
+  c3.intf.mydo;
+  if l<>1 then
+    halt(1);
+  c3.free;
+end.