paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-18 12:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ add CreateImplementation to TRttiMethod to create an implementation of a method that can be used with a VMT

Browse Source 
git-svn-id: trunk@41835 -
This commit is contained in:
svenbarth 2019-04-04 19:32:16 +00:00
parent 69f54b31e7
commit bbac2c1fbf
1 changed files with 81 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -399,6 +399,7 @@ type
TRttiMethod = class(TRttiMember)
private
FString: String;
function GetFlags: TFunctionCallFlags;
protected
function GetCallingConvention: TCallConv; virtual; abstract;
function GetCodeAddress: CodePointer; virtual; abstract;
@ -429,6 +430,9 @@ type
function Invoke(aInstance: TObject; const aArgs: array of TValue): TValue;
function Invoke(aInstance: TClass; const aArgs: array of TValue): TValue;
function Invoke(aInstance: TValue; const aArgs: array of TValue): TValue;
{ Note: once "reference to" is supported these will be replaced by a single method }
function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod): TMethodImplementation;
function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackProc): TMethodImplementation;
end;
TRttiStructuredType = class(TRttiType)
@ -2610,6 +2614,13 @@ begin
Result := False;
end;
function TRttiMethod.GetFlags: TFunctionCallFlags;
begin
Result := [];
if IsStatic then
Include(Result, fcfStatic);
end;
function TRttiMethod.GetParameters: specialize TArray<TRttiParameter>;
begin
Result := GetParameters(False);
@ -2714,6 +2725,76 @@ begin
Result := Rtti.Invoke(Name, addr, CallingConvention, IsStatic, aInstance, aArgs, GetParameters(True), ReturnType);
end;
function TRttiMethod.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod): TMethodImplementation;
var
params: specialize TArray<TRttiParameter>;
args: specialize TArray<TFunctionCallParameterInfo>;
res: PTypeInfo;
restype: TRttiType;
resinparam: Boolean;
i: SizeInt;
begin
if not Assigned(aCallback) then
raise EArgumentNilException.Create(SErrMethodImplNoCallback);
resinparam := False;
params := GetParameters(True);
SetLength(args, Length(params));
for i := 0 to High(params) do begin
if Assigned(params[i].ParamType) then
args[i].ParamType := params[i].ParamType.FTypeInfo
else
args[i].ParamType := Nil;
args[i].ParamFlags := params[i].Flags;
args[i].ParaLocs := Nil;
if pfResult in params[i].Flags then
resinparam := True;
end;
restype := GetReturnType;
if Assigned(restype) and not resinparam then
res := restype.FTypeInfo
else
res := Nil;
Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, aUserData, aCallback);
end;
function TRttiMethod.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallbackProc): TMethodImplementation;
var
params: specialize TArray<TRttiParameter>;
args: specialize TArray<TFunctionCallParameterInfo>;
res: PTypeInfo;
restype: TRttiType;
resinparam: Boolean;
i: SizeInt;
begin
if not Assigned(aCallback) then
raise EArgumentNilException.Create(SErrMethodImplNoCallback);
resinparam := False;
params := GetParameters(True);
SetLength(args, Length(params));
for i := 0 to High(params) do begin
if Assigned(params[i].ParamType) then
args[i].ParamType := params[i].ParamType.FTypeInfo
else
args[i].ParamType := Nil;
args[i].ParamFlags := params[i].Flags;
args[i].ParaLocs := Nil;
if pfResult in params[i].Flags then
resinparam := True;
end;
restype := GetReturnType;
if Assigned(restype) and not resinparam then
res := restype.FTypeInfo
else
res := Nil;
Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, aUserData, aCallback);
end;
{ TRttiInvokableType }
function TRttiInvokableType.GetParameters: specialize TArray<TRttiParameter>;