mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-18 07:06:39 +02:00
+ interfaces support
This commit is contained in:
florian
parent
d3e3b54dc4
commit
747f3d9552
@ -164,26 +164,18 @@ asm
|
||||
jmp .LExitFinalize
|
||||
// Interfaces
|
||||
.LDoInterfaceFinal:
|
||||
pushl Data
|
||||
call FPC_INTF_DECR_REF
|
||||
jmp .LExitFinalize
|
||||
// Variants
|
||||
.LDoVariantFinal:
|
||||
jmp .LExitFinalize
|
||||
// dynamic Array
|
||||
.LDoDynArrayFinal:
|
||||
// load count
|
||||
movl Data,%edx
|
||||
orl %edx,%edx
|
||||
jz .LExitFinalize
|
||||
movl -4(%edx),%edx
|
||||
incl %ebx
|
||||
movzbl (%ebx),%eax
|
||||
incl %eax
|
||||
addl %eax,%ebx
|
||||
// %ebx points to size. Put size in ecx
|
||||
movl (%ebx),%ecx
|
||||
// %ebx points to type. Put into ebx.
|
||||
addl $4, %ebx
|
||||
jmp .LMyArrayFinalLoop
|
||||
pushl TypeInfo
|
||||
pushl Data
|
||||
call DYNARRAY_DECR_REF
|
||||
jmp .LExitFinalize
|
||||
.LDoClassFinal:
|
||||
.LDoObjectFinal:
|
||||
.LDoRecordFinal:
|
||||
@ -286,6 +278,8 @@ asm
|
||||
jmp .LExitAddRef
|
||||
// Interfaces
|
||||
.LDoInterfaceAddRef:
|
||||
pushl Data
|
||||
call FPC_INTF_INCR_REF
|
||||
jmp .LExitAddRef
|
||||
// Variants
|
||||
.LDoVariantAddRef:
|
||||
@ -293,10 +287,10 @@ asm
|
||||
// Dynamic Arrays
|
||||
.LDoDynArrayAddRef:
|
||||
movl Data,%eax
|
||||
testl %eax,%eax
|
||||
je .LExitAddRef
|
||||
orl %eax,%eax
|
||||
jz .LExitAddRef
|
||||
lock
|
||||
incl -4(%eax)
|
||||
incl -8(%eax)
|
||||
jmp .LExitAddRef
|
||||
.LDoClassAddRef:
|
||||
.LDoObjectAddRef:
|
||||
@ -398,12 +392,17 @@ asm
|
||||
jmp .LExitDecRef
|
||||
// Interfaces
|
||||
.LDoInterfaceDecRef:
|
||||
pushl Data
|
||||
call FPC_INTF_DECR_REF
|
||||
jmp .LExitDecRef
|
||||
// Variants
|
||||
.LDoVariantDecRef:
|
||||
jmp .LExitDecRef
|
||||
// Dynamic Arrays
|
||||
.LDoDynArrayDecRef:
|
||||
pushl TypeInfo
|
||||
pushl Data
|
||||
call DYNARRAY_DECR_REF
|
||||
jmp .LExitDecRef
|
||||
.LDoClassDecRef:
|
||||
.LDoObjectDecRef:
|
||||
@ -473,7 +472,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-10-21 18:20:17 florian
|
||||
Revision 1.4 2000-11-04 16:30:35 florian
|
||||
+ interfaces support
|
||||
|
||||
Revision 1.3 2000/10/21 18:20:17 florian
|
||||
* a lot of small changes:
|
||||
- setlength is internal
|
||||
- win32 graph unit extended
|
||||
|
||||
@ -32,6 +32,45 @@
|
||||
handleerror(219);
|
||||
end;
|
||||
|
||||
{$ifndef ver1_0}
|
||||
{ interface helpers }
|
||||
procedure int_do_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
|
||||
begin
|
||||
if assigned(i) then
|
||||
IUnknown(i)._Release;
|
||||
i:=nil;
|
||||
end;
|
||||
|
||||
procedure int_do_intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF'];
|
||||
begin
|
||||
if assigned(i) then
|
||||
IUnknown(i)._AddRef;
|
||||
end;
|
||||
|
||||
procedure int_do_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
|
||||
begin
|
||||
if assigned(S) then IUnknown(S)._AddRef;
|
||||
if assigned(D) then IUnknown(D)._Release;
|
||||
D:=S;
|
||||
end;
|
||||
|
||||
procedure int_do_intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS'];
|
||||
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);
|
||||
if assigned(D) then IUnknown(D)._Release;
|
||||
D:=tmpi;
|
||||
end
|
||||
else
|
||||
int_do_intf_decr_ref(D);
|
||||
end;
|
||||
{$endif ver1_0}
|
||||
|
||||
{****************************************************************************
|
||||
TOBJECT
|
||||
@ -151,7 +190,7 @@
|
||||
end;
|
||||
end;
|
||||
c:=c.ClassParent;
|
||||
end;
|
||||
end;
|
||||
MethodAddress:=nil;
|
||||
end;
|
||||
|
||||
@ -342,7 +381,7 @@
|
||||
tmessagehandlerrec(msghandler).obj:=self;
|
||||
msghandler(message);
|
||||
{ we don't need any longer the assembler
|
||||
solution
|
||||
solution
|
||||
asm
|
||||
pushl message
|
||||
pushl %esi
|
||||
@ -394,7 +433,7 @@
|
||||
tmessagehandlerrec(msghandler).obj:=self;
|
||||
msghandler(message);
|
||||
{ we don't need any longer the assembler
|
||||
solution
|
||||
solution
|
||||
asm
|
||||
pushl message
|
||||
pushl %esi
|
||||
@ -445,6 +484,96 @@
|
||||
begin
|
||||
end;
|
||||
|
||||
{$ifndef ver1_0}
|
||||
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
|
||||
PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
|
||||
int_do_intf_incr_ref(pointer(obj)); { it must be an com interface }
|
||||
getinterface:=True;
|
||||
end
|
||||
else begin
|
||||
PDWORD(@Obj)^:=0;
|
||||
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
|
||||
PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
|
||||
if Assigned(IEntry^.iid) then { for Com interfaces }
|
||||
int_do_intf_incr_ref(pointer(obj));
|
||||
getinterfacebystr:=True;
|
||||
end
|
||||
else begin
|
||||
PDWORD(@Obj)^:=0;
|
||||
getinterfacebystr:=False;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TObject.getinterfaceentry(const iid : tguid) : pinterfaceentry;
|
||||
var
|
||||
i: integer;
|
||||
intftable: pinterfacetable;
|
||||
Res: pinterfaceentry;
|
||||
begin
|
||||
getinterfaceentry:=nil;
|
||||
intftable:=getinterfacetable;
|
||||
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;
|
||||
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;
|
||||
end;
|
||||
|
||||
class function TObject.getinterfacetable : pinterfacetable;
|
||||
begin
|
||||
getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
|
||||
end;
|
||||
{$endif ver1_0}
|
||||
|
||||
{****************************************************************************
|
||||
Exception Support
|
||||
****************************************************************************}
|
||||
@ -457,9 +586,12 @@
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-07-22 14:52:01 sg
|
||||
Revision 1.4 2000-11-04 16:29:54 florian
|
||||
+ interfaces support
|
||||
|
||||
Revision 1.3 2000/07/22 14:52:01 sg
|
||||
* Resolved CVS conflicts for TObject.MethodAddress patch
|
||||
|
||||
Revision 1.1.2.1 2000/07/22 14:46:57 sg
|
||||
* Made TObject.MethodAddress case independent
|
||||
}
|
||||
}
|
||||
@ -76,6 +76,28 @@
|
||||
|
||||
pstringmessagetable = ^tstringmessagetable;
|
||||
|
||||
pguid = ^tguid;
|
||||
tguid = packed record
|
||||
D1: LongWord;
|
||||
D2: Word;
|
||||
D3: Word;
|
||||
D4: array[0..7] of Byte;
|
||||
end;
|
||||
|
||||
pinterfaceentry = ^tinterfaceentry;
|
||||
tinterfaceentry = packed record
|
||||
IID: pguid; { if assigned(IID) then Com else Corba}
|
||||
VTable: Pointer;
|
||||
IOffset: LongInt;
|
||||
IIDStr: pshortstring; { never nil. Com: upper(GuidToString(IID^)) }
|
||||
end;
|
||||
|
||||
pinterfacetable = ^tinterfacetable;
|
||||
tinterfacetable = packed record
|
||||
EntryCount: Word;
|
||||
Entries: array[0..0] of tinterfaceentry;
|
||||
end;
|
||||
|
||||
tobject = class
|
||||
public
|
||||
{ please don't change the order of virtual methods, because }
|
||||
@ -116,14 +138,38 @@
|
||||
{ new for gtk, default handler for text based messages }
|
||||
procedure DefaultHandlerStr(var message);virtual;
|
||||
|
||||
{ interface functions, I don't know if we need this }
|
||||
{
|
||||
function getinterface(const iid : tguid;out obj) : boolean;
|
||||
{$ifndef ver1_0}
|
||||
{ interface functions }
|
||||
function getinterface(const iid : tguid; out obj) : boolean;
|
||||
function getinterfacebystr(const iidstr : string; out obj) : boolean;
|
||||
class function getinterfaceentry(const iid : tguid) : pinterfaceentry;
|
||||
class function getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
|
||||
class function getinterfacetable : pinterfacetable;
|
||||
}
|
||||
{$endif ver1_0}
|
||||
end;
|
||||
|
||||
{$ifndef ver1_0}
|
||||
IUnknown = interface
|
||||
['{00000000-0000-0000-C000-000000000046}']
|
||||
function QueryInterface(const iid: tguid; var {out} obj): LongInt; stdcall;
|
||||
function _AddRef: LongInt; stdcall;
|
||||
function _Release: LongInt; stdcall;
|
||||
end;
|
||||
|
||||
{ for native dispinterface support }
|
||||
IDispatch = interface(IUnknown)
|
||||
['{00020400-0000-0000-C000-000000000046}']
|
||||
function GetTypeInfoCount({out}var count: LongInt): LongInt; stdcall;
|
||||
function GetTypeInfo(Index, LocaleID: LongInt;
|
||||
var {out} TypeInfo): LongInt; stdcall;
|
||||
function GetIDsOfNames(const iid: TGUID; names: Pointer;
|
||||
NameCount, LocaleID: LongInt; DispIDs: Pointer): LongInt; stdcall;
|
||||
function Invoke(DispID: LongInt; const iid: TGUID;
|
||||
LocaleID: LongInt; Flags: Word; var params;
|
||||
VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
|
||||
end;
|
||||
{$endif ver1_0}
|
||||
|
||||
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
|
||||
|
||||
{ Exception object stack }
|
||||
@ -205,14 +251,17 @@
|
||||
vtAnsiString : (VAnsiString: Pointer);
|
||||
// vtCurrency : (VCurrency: PCurrency);
|
||||
// vtVariant : (VVariant: PVariant);
|
||||
// vtInterface : (VInterface: Pointer);
|
||||
vtInterface : (VInterface: Pointer);
|
||||
vtWideString : (VWideString: Pointer);
|
||||
vtInt64 : (VInt64: PInt64);
|
||||
vtQWord : (VQWord: PQWord);
|
||||
end;
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2000-09-30 07:38:07 sg
|
||||
Revision 1.5 2000-11-04 16:28:55 florian
|
||||
+ interfaces support
|
||||
|
||||
Revision 1.4 2000/09/30 07:38:07 sg
|
||||
* Added 'RaiseProc': A user-definable callback procedure which gets
|
||||
called whenever an exception is being raised
|
||||
|
||||
@ -221,5 +270,5 @@
|
||||
|
||||
Revision 1.2 2000/07/13 11:33:45 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user