mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-14 12:59:26 +02:00
817 lines
25 KiB
PHP
817 lines
25 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by the Free Pascal development team
|
|
|
|
This unit makes Free Pascal as much as possible Delphi compatible
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************
|
|
Internal Routines called from the Compiler
|
|
****************************************************************************}
|
|
|
|
{ the reverse order of the parameters make code generation easier }
|
|
function fpc_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
fpc_do_is:=assigned(aobject) and assigned(aclass) and
|
|
aobject.inheritsfrom(aclass);
|
|
end;
|
|
|
|
|
|
{ the reverse order of the parameters make code generation easier }
|
|
function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
|
|
handleerrorframe(219,get_frame);
|
|
result := aobject;
|
|
end;
|
|
|
|
{$ifndef HASINTF}
|
|
{ dummies for make cycle with 1.0.x }
|
|
procedure fpc_intf_decr_ref(var i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}[public,alias: 'FPC_INTF_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
end;
|
|
|
|
procedure fpc_intf_incr_ref(i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}[public,alias: 'FPC_INTF_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
end;
|
|
|
|
procedure fpc_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
end;
|
|
|
|
function fpc_intf_as(const S: pointer; const iid: TGUID): pointer;[public,alias: 'FPC_INTF_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
end;
|
|
|
|
function fpc_class_as_intf(const S: pointer; const iid: TGUID): pointer;[public,alias: 'FPC_CLASS_AS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
end;
|
|
|
|
{$else HASINTF}
|
|
|
|
{ interface helpers }
|
|
procedure fpc_intf_decr_ref(var i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}[public,alias: 'FPC_INTF_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if assigned(i) then
|
|
IUnknown(i)._Release;
|
|
i:=nil;
|
|
end;
|
|
|
|
{$ifdef hascompilerproc}
|
|
{ local declaration for intf_decr_ref for local access }
|
|
procedure intf_decr_ref(var i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif} [external name 'FPC_INTF_DECR_REF'];
|
|
{$endif hascompilerproc}
|
|
|
|
|
|
procedure fpc_intf_incr_ref(i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}[public,alias: 'FPC_INTF_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if assigned(i) then
|
|
IUnknown(i)._AddRef;
|
|
end;
|
|
|
|
{$ifdef hascompilerproc}
|
|
{ local declaration of intf_incr_ref for local access }
|
|
procedure intf_incr_ref(i: pointer);{$ifndef NOSAVEREGISTERS}saveregisters;{$endif} [external name 'FPC_INTF_INCR_REF'];
|
|
{$endif hascompilerproc}
|
|
|
|
procedure fpc_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
if assigned(S) then
|
|
IUnknown(S)._AddRef;
|
|
if assigned(D) then
|
|
IUnknown(D)._Release;
|
|
D:=S;
|
|
end;
|
|
|
|
function fpc_intf_as(const S: pointer; const iid: TGUID): pointer;[public,alias: 'FPC_INTF_AS']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
const
|
|
S_OK = 0;
|
|
var
|
|
tmpi: pointer; // _AddRef before _Release
|
|
begin
|
|
if assigned(S) then
|
|
begin
|
|
if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
|
|
handleerror(219);
|
|
fpc_intf_as:=tmpi;
|
|
end
|
|
else
|
|
fpc_intf_as:=nil;
|
|
end;
|
|
|
|
|
|
function fpc_class_as_intf(const S: pointer; const iid: TGUID): pointer;[public,alias: 'FPC_CLASS_AS_INTF']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
const
|
|
S_OK = 0;
|
|
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_intf:=tmpi;
|
|
end
|
|
else
|
|
fpc_class_as_intf:=nil;
|
|
end;
|
|
{$endif HASINTF}
|
|
|
|
|
|
function aligntoptr(p : pointer) : pointer;
|
|
begin
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
if (ptrint(p) mod sizeof(ptrint))<>0 then
|
|
inc(ptrint(p),sizeof(ptrint)-ptrint(p) mod sizeof(ptrint));
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
result:=p;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TOBJECT
|
|
****************************************************************************}
|
|
|
|
constructor TObject.Create;
|
|
|
|
begin
|
|
end;
|
|
|
|
destructor TObject.Destroy;
|
|
|
|
begin
|
|
end;
|
|
|
|
procedure TObject.Free;
|
|
|
|
begin
|
|
// the call via self avoids a warning
|
|
if self<>nil then
|
|
self.destroy;
|
|
end;
|
|
|
|
class function TObject.InstanceSize : LongInt;
|
|
|
|
begin
|
|
InstanceSize:=plongint(pointer(self)+vmtInstanceSize)^;
|
|
end;
|
|
|
|
procedure InitInterfacePointers(objclass: tclass;instance : pointer);
|
|
|
|
{$ifdef HASINTF}
|
|
var
|
|
intftable : pinterfacetable;
|
|
i : longint;
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
IOffset : longint;
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
begin
|
|
while assigned(objclass) do
|
|
begin
|
|
intftable:=pinterfacetable((pointer(objclass)+vmtIntfTable)^);
|
|
if assigned(intftable) then
|
|
for i:=0 to intftable^.EntryCount-1 do
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
begin
|
|
move(intftable^.Entries[i].IOffset,IOffset,sizeof(longint));
|
|
move(pointer(intftable^.Entries[i].VTable),ppointer(@(PChar(instance)[IOffset]))^,sizeof(pointer));
|
|
end;
|
|
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
ppointer(@(PChar(instance)[intftable^.Entries[i].IOffset]))^:=
|
|
pointer(intftable^.Entries[i].VTable);
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
objclass:=pclass(pointer(objclass)+vmtParent)^;
|
|
end;
|
|
end;
|
|
{$else HASINTF}
|
|
begin
|
|
end;
|
|
{$endif HASINTF}
|
|
|
|
class function TObject.InitInstance(instance : pointer) : tobject;
|
|
|
|
begin
|
|
{ the size is saved at offset 0 }
|
|
fillchar(instance^,plongint(pointer(self)+vmtInstanceSize)^,0);
|
|
{ insert VMT pointer into the new created memory area }
|
|
{ (in class methods self contains the VMT!) }
|
|
ppointer(instance)^:=pointer(self);
|
|
{$ifdef HASINTF}
|
|
InitInterfacePointers(self,instance);
|
|
{$endif HASINTF}
|
|
InitInstance:=TObject(Instance);
|
|
end;
|
|
|
|
class function TObject.ClassParent : tclass;
|
|
|
|
begin
|
|
{ type of self is class of tobject => it points to the vmt }
|
|
{ the parent vmt is saved at offset vmtParent }
|
|
classparent:=pclass(pointer(self)+vmtParent)^;
|
|
end;
|
|
|
|
class function TObject.NewInstance : tobject;
|
|
|
|
var
|
|
p : pointer;
|
|
|
|
begin
|
|
getmem(p,plongint(pointer(self)+vmtInstanceSize)^);
|
|
if p <> nil then
|
|
InitInstance(p);
|
|
NewInstance:=TObject(p);
|
|
end;
|
|
|
|
procedure TObject.FreeInstance;
|
|
|
|
begin
|
|
CleanupInstance;
|
|
FreeMem(Pointer(Self));
|
|
end;
|
|
|
|
class function TObject.ClassType : TClass;
|
|
|
|
begin
|
|
ClassType:=TClass(Pointer(Self))
|
|
end;
|
|
|
|
type
|
|
tmethodnamerec = packed record
|
|
name : pshortstring;
|
|
addr : pointer;
|
|
end;
|
|
|
|
tmethodnametable = packed record
|
|
count : dword;
|
|
entries : packed array[0..0] of tmethodnamerec;
|
|
end;
|
|
|
|
pmethodnametable = ^tmethodnametable;
|
|
|
|
class function TObject.MethodAddress(const name : shortstring) : pointer;
|
|
|
|
var
|
|
UName : ShortString;
|
|
methodtable : pmethodnametable;
|
|
i : dword;
|
|
vmt : tclass;
|
|
|
|
begin
|
|
UName := UpCase(name);
|
|
vmt:=self;
|
|
while assigned(vmt) do
|
|
begin
|
|
methodtable:=pmethodnametable((Pointer(vmt)+vmtMethodTable)^);
|
|
if assigned(methodtable) then
|
|
begin
|
|
for i:=0 to methodtable^.count-1 do
|
|
if UpCase(methodtable^.entries[i].name^)=UName then
|
|
begin
|
|
MethodAddress:=methodtable^.entries[i].addr;
|
|
exit;
|
|
end;
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
MethodAddress:=nil;
|
|
end;
|
|
|
|
|
|
class function TObject.MethodName(address : pointer) : shortstring;
|
|
var
|
|
methodtable : pmethodnametable;
|
|
i : dword;
|
|
vmt : tclass;
|
|
begin
|
|
vmt:=self;
|
|
while assigned(vmt) do
|
|
begin
|
|
methodtable:=pmethodnametable((Pointer(vmt)+vmtMethodTable)^);
|
|
if assigned(methodtable) then
|
|
begin
|
|
for i:=0 to methodtable^.count-1 do
|
|
if methodtable^.entries[i].addr=address then
|
|
begin
|
|
MethodName:=methodtable^.entries[i].name^;
|
|
exit;
|
|
end;
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
MethodName:='';
|
|
end;
|
|
|
|
|
|
function TObject.FieldAddress(const name : shortstring) : pointer;
|
|
type
|
|
PFieldInfo = ^TFieldInfo;
|
|
TFieldInfo = packed record
|
|
FieldOffset: LongWord;
|
|
ClassTypeIndex: Word;
|
|
Name: ShortString;
|
|
end;
|
|
|
|
PFieldTable = ^TFieldTable;
|
|
TFieldTable = packed record
|
|
FieldCount: Word;
|
|
ClassTable: Pointer;
|
|
{ Fields: array[Word] of TFieldInfo; Elements have variant size! }
|
|
end;
|
|
|
|
var
|
|
UName: ShortString;
|
|
CurClassType: TClass;
|
|
FieldTable: PFieldTable;
|
|
FieldInfo: PFieldInfo;
|
|
i: Integer;
|
|
|
|
begin
|
|
if Length(name) > 0 then
|
|
begin
|
|
UName := UpCase(name);
|
|
CurClassType := ClassType;
|
|
while CurClassType <> nil do
|
|
begin
|
|
FieldTable := PFieldTable((Pointer(CurClassType) + vmtFieldTable)^);
|
|
if FieldTable <> nil then
|
|
begin
|
|
FieldInfo := PFieldInfo(Pointer(FieldTable) + 6);
|
|
for i := 0 to FieldTable^.FieldCount - 1 do
|
|
begin
|
|
if UpCase(FieldInfo^.Name) = UName then
|
|
begin
|
|
fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset;
|
|
exit;
|
|
end;
|
|
Inc(Pointer(FieldInfo), 7 + Length(FieldInfo^.Name));
|
|
end;
|
|
end;
|
|
{ Try again with the parent class type }
|
|
CurClassType:=pclass(pointer(CurClassType)+vmtParent)^;
|
|
end;
|
|
end;
|
|
|
|
fieldaddress:=nil;
|
|
end;
|
|
|
|
function TObject.SafeCallException(exceptobject : tobject;
|
|
exceptaddr : pointer) : longint;
|
|
|
|
begin
|
|
safecallexception:=0;
|
|
end;
|
|
|
|
class function TObject.ClassInfo : pointer;
|
|
|
|
begin
|
|
ClassInfo:=ppointer(Pointer(self)+vmtTypeInfo)^;
|
|
end;
|
|
|
|
class function TObject.ClassName : ShortString;
|
|
|
|
begin
|
|
ClassName:=PShortString((Pointer(Self)+vmtClassName)^)^;
|
|
end;
|
|
|
|
class function TObject.ClassNameIs(const name : string) : boolean;
|
|
|
|
begin
|
|
ClassNameIs:=Upcase(ClassName)=Upcase(name);
|
|
end;
|
|
|
|
class function TObject.InheritsFrom(aclass : TClass) : Boolean;
|
|
|
|
var
|
|
vmt : tclass;
|
|
|
|
begin
|
|
vmt:=self;
|
|
while assigned(vmt) do
|
|
begin
|
|
if vmt=aclass then
|
|
begin
|
|
InheritsFrom:=true;
|
|
exit;
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
InheritsFrom:=false;
|
|
end;
|
|
|
|
class function TObject.stringmessagetable : pstringmessagetable;
|
|
|
|
type
|
|
pdword = ^dword;
|
|
|
|
begin
|
|
stringmessagetable:=pstringmessagetable((pointer(Self)+vmtMsgStrPtr)^);
|
|
end;
|
|
|
|
type
|
|
tmessagehandler = procedure(var msg) of object;
|
|
tmessagehandlerrec = packed record
|
|
proc : pointer;
|
|
obj : pointer;
|
|
end;
|
|
|
|
|
|
procedure TObject.Dispatch(var message);
|
|
|
|
type
|
|
tmsgtable = packed record
|
|
index : dword;
|
|
method : pointer;
|
|
end;
|
|
|
|
pmsgtable = ^tmsgtable;
|
|
|
|
var
|
|
index : dword;
|
|
count,i : longint;
|
|
msgtable : pmsgtable;
|
|
p : pointer;
|
|
vmt : tclass;
|
|
msghandler : tmessagehandler;
|
|
|
|
begin
|
|
index:=dword(message);
|
|
vmt:=ClassType;
|
|
while assigned(vmt) do
|
|
begin
|
|
// See if we have messages at all in this class.
|
|
p:=pointer(vmt)+vmtDynamicTable;
|
|
If Assigned(p) and (Pdword(p)^<>0) then
|
|
begin
|
|
msgtable:=pmsgtable(PtrInt(p^)+4);
|
|
count:=pdword(p^)^;
|
|
end
|
|
else
|
|
Count:=0;
|
|
{ later, we can implement a binary search here }
|
|
for i:=0 to count-1 do
|
|
begin
|
|
if index=msgtable[i].index then
|
|
begin
|
|
p:=msgtable[i].method;
|
|
tmessagehandlerrec(msghandler).proc:=p;
|
|
tmessagehandlerrec(msghandler).obj:=self;
|
|
msghandler(message);
|
|
exit;
|
|
end;
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
DefaultHandler(message);
|
|
end;
|
|
|
|
procedure TObject.DispatchStr(var message);
|
|
|
|
type
|
|
PSizeUInt = ^SizeUInt;
|
|
|
|
var
|
|
name : shortstring;
|
|
count,i : longint;
|
|
msgstrtable : pmsgstrtable;
|
|
p : pointer;
|
|
vmt : tclass;
|
|
msghandler : tmessagehandler;
|
|
|
|
begin
|
|
name:=pshortstring(@message)^;
|
|
vmt:=ClassType;
|
|
while assigned(vmt) do
|
|
begin
|
|
p:=(pointer(vmt)+vmtMsgStrPtr);
|
|
If (P<>Nil) and (PDWord(P)^<>0) then
|
|
begin
|
|
count:=pdword(PSizeUInt(p)^)^;
|
|
msgstrtable:=pmsgstrtable(PSizeUInt(P)^+4);
|
|
end
|
|
else
|
|
Count:=0;
|
|
{ later, we can implement a binary search here }
|
|
for i:=0 to count-1 do
|
|
begin
|
|
if name=msgstrtable[i].name^ then
|
|
begin
|
|
p:=msgstrtable[i].method;
|
|
tmessagehandlerrec(msghandler).proc:=p;
|
|
tmessagehandlerrec(msghandler).obj:=self;
|
|
msghandler(message);
|
|
exit;
|
|
end;
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
DefaultHandlerStr(message);
|
|
end;
|
|
|
|
procedure TObject.DefaultHandler(var message);
|
|
|
|
begin
|
|
end;
|
|
|
|
procedure TObject.DefaultHandlerStr(var message);
|
|
|
|
begin
|
|
end;
|
|
|
|
procedure TObject.CleanupInstance;
|
|
|
|
Type
|
|
TRecElem = Record
|
|
Info : Pointer;
|
|
Offset : Longint;
|
|
end;
|
|
|
|
TRecElemArray = Array[1..Maxint] of TRecElem;
|
|
|
|
PRecRec = ^TRecRec;
|
|
TRecRec = record
|
|
Size,Count : Longint;
|
|
Elements : TRecElemArray;
|
|
end;
|
|
|
|
var
|
|
vmt : tclass;
|
|
temp : pbyte;
|
|
count,
|
|
i : longint;
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
recelem : TRecElem;
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
begin
|
|
vmt:=ClassType;
|
|
while vmt<>nil do
|
|
begin
|
|
{ This need to be included here, because Finalize()
|
|
has should support for tkClass }
|
|
Temp:=Pointer((Pointer(vmt)+vmtInitTable)^);
|
|
if Assigned(Temp) then
|
|
begin
|
|
inc(Temp);
|
|
I:=Temp^;
|
|
inc(temp,I+1); // skip name string;
|
|
{$ifdef FPC_ALIGNSRTTI}
|
|
temp:=aligntoptr(temp);
|
|
{$endif FPC_ALIGNSRTTI}
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
move(PRecRec(Temp)^.Count,Count,sizeof(Count));
|
|
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
Count:=PRecRec(Temp)^.Count; // get element Count
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
For I:=1 to count do
|
|
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
begin
|
|
move(PRecRec(Temp)^.elements[I],RecElem,sizeof(RecElem));
|
|
With RecElem do
|
|
int_Finalize (pointer(self)+Offset,Info);
|
|
end;
|
|
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
With PRecRec(Temp)^.elements[I] do
|
|
int_Finalize (pointer(self)+Offset,Info);
|
|
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
end;
|
|
vmt:=pclass(pointer(vmt)+vmtParent)^;
|
|
end;
|
|
end;
|
|
|
|
procedure TObject.AfterConstruction;
|
|
|
|
begin
|
|
end;
|
|
|
|
procedure TObject.BeforeDestruction;
|
|
|
|
begin
|
|
end;
|
|
|
|
{$ifdef HASINTF}
|
|
function IsGUIDEqual(const guid1, guid2: tguid): boolean;
|
|
begin
|
|
IsGUIDEqual:=
|
|
(guid1.D1=guid2.D1) and
|
|
(PDWORD(@guid1.D2)^=PDWORD(@guid2.D2)^) and
|
|
(PDWORD(@guid1.D4[0])^=PDWORD(@guid2.D4[0])^) and
|
|
(PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
|
|
end;
|
|
|
|
function TObject.getinterface(const iid : tguid;out obj) : boolean;
|
|
var
|
|
IEntry: pinterfaceentry;
|
|
begin
|
|
IEntry:=getinterfaceentry(iid);
|
|
if Assigned(IEntry) then begin
|
|
PPointer(@obj)^:=Pointer(Self)+IEntry^.IOffset;
|
|
intf_incr_ref(pointer(obj)); { it must be an com interface }
|
|
getinterface:=True;
|
|
end
|
|
else begin
|
|
PPointer(@Obj)^:=nil;
|
|
getinterface:=False;
|
|
end;
|
|
end;
|
|
|
|
function TObject.getinterfacebystr(const iidstr : string;out obj) : boolean;
|
|
var
|
|
IEntry: pinterfaceentry;
|
|
begin
|
|
IEntry:=getinterfaceentrybystr(iidstr);
|
|
if Assigned(IEntry) then begin
|
|
PPointer(@obj)^:=Pointer(Self)+IEntry^.IOffset;
|
|
if Assigned(IEntry^.iid) then { for Com interfaces }
|
|
intf_incr_ref(pointer(obj));
|
|
getinterfacebystr:=True;
|
|
end
|
|
else begin
|
|
PPointer(@Obj)^:=nil;
|
|
getinterfacebystr:=False;
|
|
end;
|
|
end;
|
|
|
|
class function TObject.getinterfaceentry(const iid : tguid) : pinterfaceentry;
|
|
var
|
|
i: integer;
|
|
intftable: pinterfacetable;
|
|
Res: pinterfaceentry;
|
|
begin
|
|
getinterfaceentry:=nil;
|
|
intftable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
|
|
if assigned(intftable) then begin
|
|
i:=intftable^.EntryCount;
|
|
Res:=@intftable^.Entries[0];
|
|
while (i>0) and
|
|
not (assigned(Res^.iid) and IsGUIDEqual(Res^.iid^,iid)) do begin
|
|
inc(Res);
|
|
dec(i);
|
|
end;
|
|
if (i>0) then
|
|
getinterfaceentry:=Res;
|
|
end;
|
|
if (getinterfaceentry=nil)and not(classparent=nil) then
|
|
getinterfaceentry:=classparent.getinterfaceentry(iid)
|
|
end;
|
|
|
|
class function TObject.getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
|
|
var
|
|
i: integer;
|
|
intftable: pinterfacetable;
|
|
Res: pinterfaceentry;
|
|
begin
|
|
getinterfaceentrybystr:=nil;
|
|
intftable:=getinterfacetable;
|
|
if assigned(intftable) then begin
|
|
i:=intftable^.EntryCount;
|
|
Res:=@intftable^.Entries[0];
|
|
while (i>0) and (Res^.iidstr^<>iidstr) do begin
|
|
inc(Res);
|
|
dec(i);
|
|
end;
|
|
if (i>0) then
|
|
getinterfaceentrybystr:=Res;
|
|
end;
|
|
if (getinterfaceentrybystr=nil)and not(classparent=nil) then
|
|
getinterfaceentrybystr:=classparent.getinterfaceentrybystr(iidstr)
|
|
end;
|
|
|
|
class function TObject.getinterfacetable : pinterfacetable;
|
|
begin
|
|
getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
TINTERFACEDOBJECT
|
|
****************************************************************************}
|
|
|
|
function TInterfacedObject.QueryInterface(
|
|
const iid : tguid;out obj) : longint;stdcall;
|
|
|
|
begin
|
|
if getinterface(iid,obj) then
|
|
result:=0
|
|
else
|
|
result:=longint($80004002);
|
|
end;
|
|
|
|
function TInterfacedObject._AddRef : longint;stdcall;
|
|
|
|
begin
|
|
inclocked(frefcount);
|
|
_addref:=frefcount;
|
|
end;
|
|
|
|
function TInterfacedObject._Release : longint;stdcall;
|
|
|
|
begin
|
|
if declocked(frefcount) then
|
|
begin
|
|
destroy;
|
|
_Release:=0;
|
|
end
|
|
else
|
|
_Release:=frefcount;
|
|
end;
|
|
|
|
procedure TInterfacedObject.AfterConstruction;
|
|
|
|
begin
|
|
{ we need to fix the refcount we forced in newinstance }
|
|
{ further, it must be done in a thread safe way }
|
|
declocked(frefcount);
|
|
end;
|
|
|
|
procedure TInterfacedObject.BeforeDestruction;
|
|
|
|
begin
|
|
if frefcount<>0 then
|
|
HandleError(204);
|
|
end;
|
|
|
|
class function TInterfacedObject.NewInstance : TObject;
|
|
|
|
begin
|
|
NewInstance:=inherited NewInstance;
|
|
TInterfacedObject(NewInstance).frefcount:=1;
|
|
end;
|
|
|
|
{$endif HASINTF}
|
|
|
|
{****************************************************************************
|
|
Exception Support
|
|
****************************************************************************}
|
|
|
|
{$i except.inc}
|
|
|
|
{****************************************************************************
|
|
Initialize
|
|
****************************************************************************}
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.42 2004-10-24 20:01:41 peter
|
|
* saveregisters calling convention is obsolete
|
|
|
|
Revision 1.41 2004/10/10 19:18:31 florian
|
|
* fixed aligntoptr
|
|
|
|
Revision 1.40 2004/10/05 20:21:23 florian
|
|
* bootstrapping with rtti alignment fixed
|
|
|
|
Revision 1.39 2004/10/04 21:26:16 florian
|
|
* rtti alignment fixed
|
|
|
|
Revision 1.38 2004/04/29 21:33:22 florian
|
|
* fixed tobject.dispatch for 64 bit cpus
|
|
|
|
Revision 1.37 2004/04/28 20:48:20 peter
|
|
* ordinal-pointer conversions fixed
|
|
|
|
Revision 1.36 2004/03/22 22:19:36 florian
|
|
* more alignment fixes
|
|
|
|
Revision 1.35 2004/03/21 22:41:29 florian
|
|
* CleanupInstance takes now care of FPC_REQUIRES_PROPER_ALIGNMENT
|
|
|
|
Revision 1.34 2004/02/26 16:19:01 peter
|
|
* tkclass removed from finalize()
|
|
* cleanupinstance now parses the tkclass rtti entry itself and
|
|
calls finalize() for the rtti members
|
|
|
|
Revision 1.33 2003/07/19 11:19:07 michael
|
|
+ fix from Ivan Shikhalev for QueryInterface to return ancestor methods
|
|
|
|
Revision 1.32 2003/05/01 08:05:23 florian
|
|
* started to make the rtl 64 bit save by introducing SizeInt and SizeUInt (similar to size_t of C)
|
|
|
|
Revision 1.31 2003/03/17 20:55:58 peter
|
|
* ClassType changed to class method
|
|
|
|
Revision 1.30 2002/10/19 15:53:20 peter
|
|
* 'inlined' some more calls
|
|
|
|
Revision 1.29 2002/10/15 19:29:49 peter
|
|
* manual inline classparent calls in the loops
|
|
|
|
Revision 1.28 2002/10/11 14:05:21 florian
|
|
* initinterfacepointers improved
|
|
|
|
Revision 1.27 2002/09/07 15:07:46 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.26 2002/09/07 11:08:58 carl
|
|
- remove logs
|
|
|
|
Revision 1.25 2002/08/31 13:11:11 florian
|
|
* several fixes for Linux/PPC compilation
|
|
|
|
} |