paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-05 02:27:20 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Invoke helper definition, allow calling it

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-07-11 11:10:35 +02:00 committed by Michael Van Canneyt
parent 125bd9d5e9
commit 90f902c7d4
1 changed files with 73 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
rtl/objpas/typinfo.pp
View File

@ -131,6 +131,11 @@ unit TypInfo;
);
{$pop}
{$IF FPC_FULLVERSION>=30301}
{$DEFINE HAVE_INVOKEHELPER}
{$DEFINE HAVE_HIDDENTHUNKCLASS}
{$ENDIF}
{$MINENUMSIZE DEFAULT}
const
@ -143,6 +148,10 @@ unit TypInfo;
TTypeKinds = set of TTypeKind;
ShortStringBase = string[255];
{$IFDEF HAVE_INVOKEHELPER}
TInvokeHelper = procedure(Instance : Pointer; Args : PPointer);
{$ENDIF}
PParameterLocation = ^TParameterLocation;
TParameterLocation =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@ -378,6 +387,7 @@ unit TypInfo;
property Next: PVmtMethodParam read GetNext;
end;
PIntfMethodEntry = ^TIntfMethodEntry;
TIntfMethodEntry =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@ -396,6 +406,9 @@ unit TypInfo;
Kind: TMethodKind;
ParamCount: Word;
StackSize: SizeInt;
{$IFDEF HAVE_INVOKEHELPER}
InvokeHelper : TInvokeHelper;
{$ENDIF}
NamePtr: PShortString;
{ Params: array[0..ParamCount - 1] of TVmtMethodParam }
{ ResultLocs: PParameterLocations (if ResultType != Nil) }
@ -515,7 +528,9 @@ unit TypInfo;
Parent: PPTypeInfo;
Flags: TIntfFlagsBase;
GUID: TGUID;
{$IFDEF HAVE_HIDDENTHUNKCLASS}
ThunkClass : PPTypeInfo;
{$ENDIF}
UnitNameField: ShortString;
{ PropertyTable: TPropData }
{ MethodTable: TIntfMethodTable }
@ -556,7 +571,9 @@ unit TypInfo;
Parent: PPTypeInfo;
Flags : TIntfFlagsBase;
IID: TGUID;
{$IFDEF HAVE_HIDDENTHUNKCLASS}
ThunkClass : PPTypeInfo;
{$ENDIF}
UnitNameField: ShortString;
{ IIDStr: ShortString; }
{ PropertyTable: TPropData }
@ -981,6 +998,7 @@ function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
procedure SetDynArrayProp(Instance: TObject; const PropName: string; const Value: Pointer);
procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
// Extended RTTI
function GetAttributeTable(TypeInfo: PTypeInfo): PAttributeTable;
@ -988,6 +1006,10 @@ function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: Word): TCustomAttrib
function GetAttribute(AttributeTable: PAttributeTable; AttributeNr: Word): TCustomAttribute;
{$IFDEF HAVE_INVOKEHELPER}
procedure CallInvokeHelper(aTypeInfo : PTypeInfo; Instance: Pointer; const aMethod : String; aArgs : PPointer);
{$ENDIF}
// Auxiliary routines, which may be useful
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@ -3789,5 +3811,56 @@ begin
end;
end;
{$IFDEF HAVE_INVOKEHELPER}
procedure CallInvokeHelper(Instance: Pointer; aMethod : PIntfMethodEntry; aArgs : PPointer);
begin
if (aMethod=Nil) then
Raise EArgumentNilException.Create('Cannot call invoke helper on nil method info');
if (aMethod^.InvokeHelper=Nil) then
Raise EArgumentException.CreateFmt('Method %s has no invoke helper.',[aMethod^.Name]);
aMethod^.InvokeHelper(Instance,aArgs);
end;
procedure CallInvokeHelper(aTypeInfo : PTypeInfo; Instance: Pointer; const aMethod : String; aArgs : PPointer);
Var
Data : PInterfaceData;
DataR : PInterfaceRawData;
MethodTable : PIntfMethodTable;
MethodEntry : PIntfMethodEntry;
I : Integer;
begin
If Instance=Nil then
Raise EArgumentNilException.Create('Cannot call invoke helper on nil instance');
if not (aTypeInfo^.Kind in [tkInterface,tkInterfaceRaw]) then
Raise EArgumentException.Create('Cannot call invoke helper non non-interfaces');
// Get method table
if (aTypeInfo^.Kind=tkInterface) then
begin
Data:=PInterfaceData(GetTypeData(aTypeInfo));
MethodTable:=Data^.MethodTable;
end
else
begin
DataR:=PInterfaceRawData(GetTypeData(aTypeInfo));
MethodTable:=DataR^.MethodTable;
end;
// Search method in method table
MethodEntry:=nil;
I:=MethodTable^.Count-1;
While (MethodEntry=Nil) and (I>=0) do
begin
MethodEntry:=MethodTable^.Method[i];
if not SameText(MethodEntry^.Name,aMethod) then
MethodEntry:=Nil;
Dec(I);
end;
if MethodEntry=Nil then
Raise EArgumentException.CreateFmt('Interface %s has no method %s.',[aTypeInfo^.Name,aMethod]);
CallInvokeHelper(Instance,MethodEntry,aArgs);
end;
{$ENDIF HAVE_INVOKEHELPER}
end.