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

* implemented intf as object. When doing IInterface as TObject the compiler calls fpc_intf_as_class to query for the IImplementorGetter interface and then invokes GetObject to get the

Browse Source 
objects reference.
* by default the TInterfacedObject is supporting now IImplementorGetter

git-svn-id: trunk@15080 -
This commit is contained in:
ivost 2010-03-28 00:17:20 +00:00
parent 6560ed87e9
commit dc785f6f68
4 changed files with 53 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/ncnv.pas
View File

@ -3384,7 +3384,14 @@ implementation
if (right.resultdef.typ=classrefdef) then
begin
{ left must be a class }
{ left maybe an interface reference }
if is_interfacecom(left.resultdef) then
begin
{ relation checks are not possible }
end
else
{ or left must be a class }
if is_class(left.resultdef) then
begin
{ the operands must be related }
@ -3397,7 +3404,7 @@ implementation
FullTypeName(tclassrefdef(right.resultdef).pointeddef,left.resultdef));
end
else
CGMessage1(type_e_class_type_expected,left.resultdef.typename);
CGMessage1(type_e_class_or_cominterface_type_expected,left.resultdef.typename);
resultdef:=tclassrefdef(right.resultdef).pointeddef;
end
else if is_interface(right.resultdef) or is_dispinterface(right.resultdef) then
@ -3487,7 +3494,10 @@ implementation
else
procname := 'fpc_class_as_intf'
else
procname := 'fpc_intf_as';
if right.resultdef.typ=classrefdef then
procname := 'fpc_intf_as_class'
else
procname := 'fpc_intf_as';
call := ccallnode.createintern(procname,
ccallparanode.create(right,ccallparanode.create(left,nil)));
call := ctypeconvnode.create_internal(call,resultdef);

1
rtl/inc/compproc.inc
View File

@ -591,6 +591,7 @@ procedure fpc_intf_incr_ref(i: pointer); compilerproc;
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_intf_as_class(const S: pointer; const aclass: tclass): pointer; 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;
{$ifdef FPC_HAS_FEATURE_VARIANTS}

30
rtl/inc/objpas.inc
View File

@ -119,6 +119,30 @@
end;
function fpc_intf_as_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_AS_CLASS']; compilerproc;
var
tmpi: pointer;
tmpo: tobject;
begin
if assigned(S) then
begin
tmpi := nil;
if IUnknown(S).QueryInterface(IImplementorGetter, tmpi)=S_OK then
begin
tmpo := IImplementorGetter(tmpi).GetObject;
IUnknown(tmpi)._Release;
if not assigned(tmpo) or not tmpo.inheritsfrom(aclass) then
handleerror(219);
fpc_intf_as_class:=tmpo;
end
else
handleerror(219);
end
else
fpc_intf_as_class:=nil;
end;
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
@ -870,6 +894,12 @@
self.destroy;
end;
function TInterfacedObject.GetObject : TObject;
begin
GetObject:=Self;
end;
procedure TInterfacedObject.AfterConstruction;
begin

10
rtl/inc/objpash.inc
View File

@ -279,13 +279,21 @@
VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
end;
TInterfacedObject = class(TObject,IUnknown)
{ for safe as operator support }
IImplementorGetter = interface
['{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}']
function GetObject : TObject;
end;
TInterfacedObject = class(TObject,IUnknown,IImplementorGetter)
protected
frefcount : longint;
{ implement methods of IUnknown }
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
{ implement methods of IImplementorGetter }
function GetObject : TObject;
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;