* proper support for tobject.getinterface with raw/corba interfaces, resolves #6798 and #6036

git-svn-id: trunk@11497 -

.gitattributes

@@ -8134,6 +8134,7 @@ tests/webtbf/tw4893e.pp svneol=native#text/plain
 tests/webtbf/tw4911.pp svneol=native#text/plain
 tests/webtbf/tw4913.pp -text
 tests/webtbf/tw5896a.pp svneol=native#text/plain
+tests/webtbf/tw6036b.pp svneol=native#text/plain
 tests/webtbf/tw6420.pp svneol=native#text/plain
 tests/webtbf/tw6631.pp svneol=native#text/plain
 tests/webtbf/tw6686.pp svneol=native#text/plain
@@ -9061,6 +9062,8 @@ tests/webtbs/tw5100a.pp svneol=native#text/plain
 tests/webtbs/tw5641.pp svneol=native#text/plain
 tests/webtbs/tw5800.pp svneol=native#text/plain
 tests/webtbs/tw5896.pp svneol=native#text/plain
+tests/webtbs/tw6036.pp svneol=native#text/plain
+tests/webtbs/tw6036a.pp svneol=native#text/plain
 tests/webtbs/tw6129.pp svneol=native#text/plain
 tests/webtbs/tw6184.pp svneol=native#text/plain
 tests/webtbs/tw6203.pp svneol=native#text/plain

compiler/defcmp.pas

@@ -497,6 +497,15 @@ implementation
                            end;
                        end;
                    end;
+                 objectdef :
+                   begin
+                     { corba interface -> id string }
+                     if is_interfacecorba(def_from) then
+                      begin
+                        doconv:=tc_intf_2_string;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
                end;
              end;
 
@@ -1362,8 +1371,8 @@ implementation
            recorddef :
              begin
                { interface -> guid }
-               if is_interface(def_from) and
-                  (def_to=rec_tguid) then
+               if (def_to=rec_tguid) and
+                  (is_interfacecom(def_from) or is_dispinterface(def_from)) then
                 begin
                   doconv:=tc_intf_2_guid;
                   eq:=te_convert_l1;

compiler/ncnv.pas

@@ -74,6 +74,7 @@ interface
           function typecheck_arrayconstructor_to_set : tnode;
           function typecheck_set_to_set : tnode;
           function typecheck_pchar_to_string : tnode;
+          function typecheck_interface_to_string : tnode;
           function typecheck_interface_to_guid : tnode;
           function typecheck_dynarray_to_openarray : tnode;
           function typecheck_pwchar_to_string : tnode;
@@ -1323,6 +1324,18 @@ implementation
       end;
 
 
+    function ttypeconvnode.typecheck_interface_to_string : tnode;
+      begin
+        if assigned(tobjectdef(left.resultdef).iidstr) then
+          begin
+            if not(oo_has_valid_guid in tobjectdef(left.resultdef).objectoptions) then
+              CGMessage1(type_interface_has_no_guid,tobjectdef(left.resultdef).typename);
+            result:=cstringconstnode.createstr(tobjectdef(left.resultdef).iidstr^);
+            tstringconstnode(result).changestringtype(cshortstringtype);
+          end;
+      end;
+
+
     function ttypeconvnode.typecheck_interface_to_guid : tnode;
       begin
         if assigned(tobjectdef(left.resultdef).iidguid) then
@@ -1590,7 +1603,7 @@ implementation
           { arrayconstructor_2_set } @ttypeconvnode.typecheck_arrayconstructor_to_set,
           { set_to_set } @ttypeconvnode.typecheck_set_to_set,
           { cord_2_pointer } @ttypeconvnode.typecheck_cord_to_pointer,
-          { intf_2_string } nil,
+          { intf_2_string } @ttypeconvnode.typecheck_interface_to_string,
           { intf_2_guid } @ttypeconvnode.typecheck_interface_to_guid,
           { class_2_intf } nil,
           { char_2_char } @ttypeconvnode.typecheck_char_to_char,

rtl/inc/objpas.inc

@@ -629,6 +629,43 @@
             IInterface(obj)._AddRef;
         end;
 
+      function getcorbainterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
+        var
+          Getter: function: IInterface of object;
+        begin
+          Pointer(Obj) := nil;
+          if Assigned(IEntry) and Assigned(Instance) then
+          begin
+            case IEntry^.IType of
+              etStandard:
+                begin
+                  //writeln('Doing etStandard cast of ', TObject(Instance).classname(), ' with self = ', ptruint(Instance), ' and offset = ', IEntry^.IOffset);
+                  Pbyte(Obj):=Pbyte(instance)+IEntry^.IOffset;
+                end;
+              etFieldValue:
+                begin
+                  //writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
+                  Pointer(obj) := ppointer(Pbyte(Instance)+IEntry^.IOffset)^;
+                end;
+              etVirtualMethodResult:
+                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());
+                end;
+              etStaticMethodResult:
+                begin
+                  //writeln('Doing etStaticMethodResult cast of ', TObject(Instance).classname());
+                  TMethod(Getter).data := Instance;
+                  TMethod(Getter).code := pointer(IEntry^.IOffset);
+                  Pointer(obj) := Pointer(Getter());
+                end;
+            end;
+          end;
+          result := assigned(pointer(obj));
+        end;
+
       function TObject.getinterface(const iid : tguid;out obj) : boolean;
         begin
           Result := getinterfacebyentry(self, getinterfaceentry(iid), obj);
@@ -636,7 +673,12 @@
 
       function TObject.getinterfacebystr(const iidstr : string;out obj) : boolean;
         begin
-          Result := getinterfacebyentry(self, getinterfaceentrybystr(iidstr), obj);
+          Result := getcorbainterfacebyentry(self, getinterfaceentrybystr(iidstr), obj);
+        end;
+
+      function TObject.getinterface(const iidstr : string;out obj) : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+        begin
+          Result := getinterfacebystr(iidstr,obj);
         end;
 
       class function TObject.getinterfaceentry(const iid : tguid) : pinterfaceentry;

rtl/inc/objpash.inc

@@ -209,6 +209,7 @@
 
           { interface functions }
           function GetInterface(const iid : tguid; out obj) : boolean;
+          function GetInterface(const iidstr : string;out obj) : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
           function GetInterfaceByStr(const iidstr : string; out obj) : boolean;
           class function GetInterfaceEntry(const iid : tguid) : pinterfaceentry;
           class function GetInterfaceEntryByStr(const iidstr : string) : pinterfaceentry;

tests/webtbf/tw6036b.pp

@@ -0,0 +1,11 @@
+{ %fail }
+{$mode objfpc}
+type
+  imyinterface = interface
+  end;
+
+var
+  s : string;
+begin
+  s:=imyinterface;
+end.

tests/webtbs/tw6036.pp

@@ -0,0 +1,82 @@
+program corbainterface;
+{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
+{$ifdef mswindows}{$apptype console}{$endif}
+uses
+ sysutils;
+
+type
+ {$interfaces corba}
+ icorbainterface1 = interface ['{9E8B9751-7779-4484-B6B7-960D18ACE7AB}']
+  procedure iproc1;
+ end;
+ icorbainterface2 = interface ['MSE1']
+  procedure iproc2;
+ end;
+
+ {$interfaces com}
+ icominterface = interface ['{BC9EF8D0-2B67-4E5C-9952-05DF15A71567}']
+  procedure iproc3;
+ end;
+
+ ttestclasscorba = class(tobject,icorbainterface1,icorbainterface2)
+  public
+   procedure iproc1;
+   procedure iproc2;
+ end;
+
+ ttestclasscom = class(tinterfacedobject,icominterface)
+  public
+   procedure iproc3;
+ end;
+
+{ ttestclass }
+
+procedure ttestclasscorba.iproc1;
+begin
+end;
+
+procedure ttestclasscorba.iproc2;
+begin
+end;
+
+{ ttestclasscom }
+
+procedure ttestclasscom.iproc3;
+begin
+end;
+
+
+var
+ testclass1: ttestclasscorba;
+ testclass2: ttestclasscom;
+ po1: pointer;
+
+begin
+ testclass1:= ttestclasscorba.create;
+ testclass2:= ttestclasscom.create;
+
+ if testclass1.getinterface(icorbainterface1,po1) then begin
+  writeln('getinterface icorbainterface1 found');
+ end
+ else begin
+  writeln('getinterface icorbainterface1 not found');
+ end;
+
+ if testclass2.getinterface(icominterface,po1) then begin
+  writeln('getinterface icominterface found');
+ end
+ else begin
+  writeln('getinterface icominterface not found');
+ end;
+
+ if testclass1.getinterfacebystr('MSE1',po1) then begin
+  writeln('getinterfacebystr MSE1 found');
+ end
+ else begin
+  writeln('getinterfacebystr MSE1 not found');
+ end;
+
+ testclass1.free;
+ testclass2._Release;
+end.
+

tests/webtbs/tw6036a.pp

@@ -0,0 +1,12 @@
+{$interfaces corba}
+{$mode objfpc}
+type
+  imyinterface = interface
+  ['MYINTERFACE']
+  end;
+
+var
+  s : string;
+begin
+  s:=imyinterface;
+end.