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

* Parent class for hidden TVirtualInterface thunking class

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-07-04 18:26:54 +02:00 committed by Michael Van Canneyt
parent d472c920ba
commit 70282826ad
3 changed files with 48 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
rtl/inc/objpas.inc
View File

@ -1224,6 +1224,28 @@
FName:=aName;
end;
{****************************************************************************
TInterfaceThunk
****************************************************************************}
Constructor TInterfaceThunk.Create(aCallback : TThunkCallback);
begin
FCallBack:=aCallBack;
end;
Procedure TInterfaceThunk.Thunk(aMethod: Longint; aCount : Longint; aData : PArgData);
begin
if Assigned(FCallBack) then
FCallBack(Self,aMethod,aCount,aData);
end;
function TInterfaceThunk.InterfaceVMTOffset : word;
begin
Result:=0;
end;
{****************************************************************************
Exception Support

23
rtl/inc/objpash.inc
View File

@ -340,7 +340,28 @@
function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
end;
TInterfaceThunk = Class(TInterfacedObject)
Public
Type
TArgData = record
addr : pointer; // Location
info : pointer; // type info (if available: nil for untyped args)
idx : smallint; // param index in rtti
ahigh : sizeint; // For open arrays, high()
end;
PArgData = ^TargData;
TThunkCallBack = Procedure(aInstance: Pointer; aMethod,aCount : Longint; aData : PArgData) of object;
Private
FCallback : TThunkCallback;
Protected
Procedure Thunk(aMethod: Longint; aCount : Longint; aData : PArgData); virtual;
Public
constructor create(aCallBack : TThunkCallback);
function InterfaceVMTOffset : word; virtual;
end;
TInterfaceThunkClass = class of TInterfaceThunk;
{ some pointer definitions }
PUnknown = ^IUnknown;

4
rtl/objpas/typinfo.pp
View File

@ -515,6 +515,7 @@ unit TypInfo;
Parent: PPTypeInfo;
Flags: TIntfFlagsBase;
GUID: TGUID;
ThunkClass : PPTypeInfo;
UnitNameField: ShortString;
{ PropertyTable: TPropData }
{ MethodTable: TIntfMethodTable }
@ -555,6 +556,7 @@ unit TypInfo;
Parent: PPTypeInfo;
Flags : TIntfFlagsBase;
IID: TGUID;
ThunkClass : PPTypeInfo;
UnitNameField: ShortString;
{ IIDStr: ShortString; }
{ PropertyTable: TPropData }
@ -756,6 +758,7 @@ unit TypInfo;
IntfParentRef: TypeInfoPtr;
IntfFlags : TIntfFlagsBase;
GUID: TGUID;
ThunkClass : PPTypeInfo;
IntfUnit: ShortString;
{ PropertyTable: TPropData }
{ MethodTable: TIntfMethodTable }
@ -765,6 +768,7 @@ unit TypInfo;
RawIntfParentRef: TypeInfoPtr;
RawIntfFlags : TIntfFlagsBase;
IID: TGUID;
RawThunkClass : PPTypeInfo;
RawIntfUnit: ShortString;
{ IIDStr: ShortString; }
{ PropertyTable: TPropData }