* fixed bug #5800

* const s: string = icorbainterface; is possible now
* as operator is working now with corba interfaces
* supports helper function is working now with corba interfaces

git-svn-id: trunk@12729 -

compiler/ncnv.pas

@@ -3336,16 +3336,31 @@ implementation
             { load the GUID of the interface }
             if (right.nodetype=typen) then
              begin
-               if assigned(tobjectdef(right.resultdef).iidguid) then
+               if tobjectdef(right.resultdef).objecttype=odt_interfacecorba then
                  begin
-                   if not(oo_has_valid_guid in tobjectdef(right.resultdef).objectoptions) then
-                     CGMessage1(type_interface_has_no_guid,tobjectdef(right.resultdef).typename);
-                   hp:=cguidconstnode.create(tobjectdef(right.resultdef).iidguid^);
-                   right.free;
-                   right:=hp;
+                   if assigned(tobjectdef(right.resultdef).iidstr) then
+                     begin
+                       hp:=cstringconstnode.createstr(tobjectdef(right.resultdef).iidstr^);
+                       tstringconstnode(hp).changestringtype(cshortstringtype);
+                       right.free;
+                       right:=hp;
+                     end
+                   else
+                     internalerror(200902081);
                  end
                else
-                 internalerror(200206282);
+                 begin
+                   if assigned(tobjectdef(right.resultdef).iidguid) then
+                     begin
+                       if not(oo_has_valid_guid in tobjectdef(right.resultdef).objectoptions) then
+                         CGMessage1(type_interface_has_no_guid,tobjectdef(right.resultdef).typename);
+                       hp:=cguidconstnode.create(tobjectdef(right.resultdef).iidguid^);
+                       right.free;
+                       right:=hp;
+                     end
+                   else
+                     internalerror(200206282);
+                 end;
                typecheckpass(right);
              end;
           end
@@ -3387,7 +3402,10 @@ implementation
             else
               begin
                 if is_class(left.resultdef) then
-                  procname := 'fpc_class_as_intf'
+                  if is_shortstring(right.resultdef) then
+                    procname := 'fpc_class_as_corbaintf'
+                  else
+                    procname := 'fpc_class_as_intf'
                 else
                   procname := 'fpc_intf_as';
                 call := ccallnode.createintern(procname,

compiler/ptconst.pas

@@ -633,6 +633,7 @@ implementation
           p.free;
         end;
 
+
         procedure parse_stringdef(list:tasmlist;def:tstringdef);
         var
           n : tnode;
@@ -645,7 +646,8 @@ implementation
         begin
           n:=comp_expr(true);
           { load strval and strlength of the constant tree }
-          if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) then
+          if (n.nodetype=stringconstn) or is_wide_or_unicode_string(def) or is_constwidecharnode(n) or
+            ((n.nodetype=typen) and is_interfacecorba(ttypenode(n).typedef)) then
             begin
               { convert to the expected string type so that
                 for widestrings strval is a pcompilerwidestring }
@@ -1014,8 +1016,7 @@ implementation
               n.free;
               exit;
             end;
-          if (def=rec_tguid) and { maybe keep token=_ID here to assign corba interfaces to TGuid }
-             ((token=_CSTRING) or (token=_CCHAR) {or (token=_ID)}) then
+          if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
             begin
               n:=comp_expr(true);
               inserttypeconv(n,cshortstringtype);

rtl/inc/compproc.inc

@@ -593,6 +593,7 @@ procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc;
 procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID); compilerproc;
 function  fpc_intf_as(const S: pointer; const iid: TGUID): IInterface; compilerproc;
 function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface; compilerproc;
+function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer; compilerproc;
 procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc: Pointer; Params: Pointer); compilerproc;
 {$endif FPC_HAS_FEATURE_CLASSES}
 

rtl/inc/objpas.inc

@@ -116,7 +116,6 @@
 
 
     function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_CLASS_AS_INTF']; compilerproc;
-
       var
         tmpi: pointer; // _AddRef before _Release
       begin
@@ -130,6 +129,21 @@
           fpc_class_as_intf:=nil;
       end;
 
+
+    function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer;[public,alias: 'FPC_CLASS_AS_CORBAINTF']; compilerproc;
+      var
+        tmpi: pointer; // _AddRef before _Release
+      begin
+        if assigned(S) then
+          begin
+             if not TObject(S).GetInterface(iid,tmpi) then
+               handleerror(219);
+             fpc_class_as_corbaintf:=tmpi;
+          end
+        else
+          fpc_class_as_corbaintf:=nil;
+      end;
+
 {****************************************************************************
                                TOBJECT
 ****************************************************************************}
@@ -590,7 +604,7 @@
             (PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
         end;
 
-      function getinterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
+      function getinterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; Corba: Boolean; out obj): boolean;
         var
           Getter: function: IInterface of object;
         begin
@@ -625,58 +639,21 @@
             end;
           end;
           result := assigned(pointer(obj));
-          if result then
+          if result and not Corba then
             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);
+          Result := getinterfacebyentry(self, getinterfaceentry(iid), false, obj);
         end;
 
-      function TObject.getinterfacebystr(const iidstr : string;out obj) : boolean;
+      function TObject.getinterfacebystr(const iidstr : shortstring;out obj) : boolean;
         begin
-          Result := getcorbainterfacebyentry(self, getinterfaceentrybystr(iidstr), obj);
+          Result := getinterfacebyentry(self, getinterfaceentrybystr(iidstr), true, obj);
         end;
 
-      function TObject.getinterface(const iidstr : string;out obj) : boolean;
+      function TObject.getinterface(const iidstr : shortstring;out obj) : boolean;
         begin
           Result := getinterfacebystr(iidstr,obj);
         end;
@@ -705,7 +682,7 @@
           result := nil;
         end;
 
-      class function TObject.getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
+      class function TObject.getinterfaceentrybystr(const iidstr : shortstring) : pinterfaceentry;
         var
           i: longint;
           intftable: pinterfacetable;
@@ -720,7 +697,7 @@
               for i:=0 to intftable^.EntryCount-1 do
               begin
                 result:=@intftable^.Entries[i];
-                if result^.iidstr^ = iidstr then
+                if assigned(result^.iidstr) and (result^.iidstr^ = iidstr) then
                   Exit;
               end;
             end;

rtl/inc/objpash.inc

@@ -209,10 +209,10 @@
 
           { interface functions }
           function GetInterface(const iid : tguid; out obj) : boolean;
-          function GetInterface(const iidstr : string;out obj) : boolean;
-          function GetInterfaceByStr(const iidstr : string; out obj) : boolean;
+          function GetInterface(const iidstr : shortstring;out obj) : boolean;
+          function GetInterfaceByStr(const iidstr : shortstring; out obj) : boolean;
           class function GetInterfaceEntry(const iid : tguid) : pinterfaceentry;
-          class function GetInterfaceEntryByStr(const iidstr : string) : pinterfaceentry;
+          class function GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
           class function GetInterfaceTable : pinterfacetable;
        end;
 

rtl/objpas/sysutils/intfh.inc

@@ -22,9 +22,12 @@
 
 function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; overload;
 function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
+function Supports(const Instance: TObject; const IID: Shortstring; out Intf): Boolean; overload;
 function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload;
 function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload;
+function Supports(const Instance: TObject; const IID: Shortstring): Boolean; overload;
 function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload;
+function Supports(const AClass: TClass; const IID: Shortstring): Boolean; overload;
 
 //function CreateGUID(out Guid: TGUID): HResult;
 function StringToGUID(const S: string): TGUID;

rtl/objpas/sysutils/sysuintf.inc

@@ -22,18 +22,17 @@
 
 function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean;
 begin
-  Result:=(Instance<>nil) and
-          (Instance.QueryInterface(IID,Intf)=0);
+  Result:=(Instance<>nil) and (Instance.QueryInterface(IID,Intf)=0);
 end;
 
 function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean;
-var
-  LUnknown: IUnknown;
 begin
-  Result:=(Instance<>nil) and
-          ((Instance.GetInterface(IUnknown,LUnknown) and
-            Supports(LUnknown,IID,Intf)) or
-           Instance.GetInterface(IID,Intf));
+  Result:=(Instance<>nil) and Instance.GetInterface(IID,Intf);
+end;
+
+function Supports(const Instance: TObject; const IID: Shortstring; out Intf): Boolean;
+begin
+  Result:=(Instance<>nil) and Instance.GetInterface(IID,Intf);
 end;
 
 function Supports(const Instance: IInterface; const IID: TGUID): Boolean;
@@ -44,15 +43,23 @@ begin
 end;
 
 function Supports(const Instance: TObject; const IID: TGUID): Boolean;
-var
-  Temp: IInterface;
 begin
-  Result:=Supports(Instance,IID,Temp);
+  Result:=(Instance<>nil) and (Instance.GetInterfaceEntry(IID)<>nil);
+end;
+
+function Supports(const Instance: TObject; const IID: Shortstring): Boolean;
+begin
+  Result:=(Instance<>nil) and (Instance.GetInterfaceEntryByStr(IID)<>nil);
 end;
 
 function Supports(const AClass: TClass; const IID: TGUID): Boolean;
 begin
-  Result:=AClass.GetInterfaceEntry(IID)<>nil;
+  Result:=(AClass<>nil) and (AClass.GetInterfaceEntry(IID)<>nil);
+end;
+
+function Supports(const AClass: TClass; const IID: Shortstring): Boolean;
+begin
+  Result:=(AClass<>nil) and (AClass.GetInterfaceEntryByStr(IID)<>nil);
 end;