paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 16:49:00 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed bug #5800

Browse Source 
* 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 -
This commit is contained in:
ivost 2009-02-09 00:35:09 +00:00
parent b3d611ab8f
commit 0438667eed
7 changed files with 79 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
compiler/ncnv.pas
View File

@ -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,

7
compiler/ptconst.pas
View File

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

1
rtl/inc/compproc.inc
View File

@ -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}

69
rtl/inc/objpas.inc
View File

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

6
rtl/inc/objpash.inc
View File

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

3
rtl/objpas/sysutils/intfh.inc
View File

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

31
rtl/objpas/sysutils/sysuintf.inc
View File

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