mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 18:29:28 +02:00
+ add TRttiMethodType for method variables and TRttiProcedureType for procedure variables
git-svn-id: trunk@39888 -
This commit is contained in:
svenbarth
parent
b8ae04140c
commit
7bb147dce0
@ -294,6 +294,37 @@ type
|
||||
function ToString: String; override;
|
||||
end;
|
||||
|
||||
TRttiInvokableType = class(TRttiType)
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; virtual; abstract;
|
||||
function GetCallingConvention: TCallConv; virtual; abstract;
|
||||
function GetReturnType: TRttiType; virtual; abstract;
|
||||
public
|
||||
function GetParameters: specialize TArray<TRttiParameter>; inline;
|
||||
property CallingConvention: TCallConv read GetCallingConvention;
|
||||
property ReturnType: TRttiType read GetReturnType;
|
||||
end;
|
||||
|
||||
TRttiMethodType = class(TRttiInvokableType)
|
||||
private
|
||||
FCallConv: TCallConv;
|
||||
FReturnType: TRttiType;
|
||||
FParams, FParamsAll: specialize TArray<TRttiParameter>;
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
|
||||
function GetCallingConvention: TCallConv; override;
|
||||
function GetReturnType: TRttiType; override;
|
||||
end;
|
||||
|
||||
TRttiProcedureType = class(TRttiInvokableType)
|
||||
private
|
||||
FParams, FParamsAll: specialize TArray<TRttiParameter>;
|
||||
protected
|
||||
function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
|
||||
function GetCallingConvention: TCallConv; override;
|
||||
function GetReturnType: TRttiType; override;
|
||||
end;
|
||||
|
||||
TDispatchKind = (
|
||||
dkStatic,
|
||||
dkVtable,
|
||||
@ -555,6 +586,21 @@ type
|
||||
constructor Create(AVmtMethodParam: PVmtMethodParam);
|
||||
end;
|
||||
|
||||
TRttiMethodTypeParameter = class(TRttiParameter)
|
||||
private
|
||||
fHandle: Pointer;
|
||||
fName: String;
|
||||
fFlags: TParamFlags;
|
||||
fType: PTypeInfo;
|
||||
protected
|
||||
function GetHandle: Pointer; override;
|
||||
function GetName: String; override;
|
||||
function GetFlags: TParamFlags; override;
|
||||
function GetParamType: TRttiType; override;
|
||||
public
|
||||
constructor Create(aHandle: Pointer; const aName: String; aFlags: TParamFlags; aType: PTypeInfo);
|
||||
end;
|
||||
|
||||
TRttiIntfMethod = class(TRttiMethod)
|
||||
private
|
||||
FIntfMethodEntry: PIntfMethodEntry;
|
||||
@ -875,6 +921,8 @@ begin
|
||||
tkWString : Result := TRttiStringType.Create(ATypeInfo);
|
||||
tkFloat : Result := TRttiFloatType.Create(ATypeInfo);
|
||||
tkPointer : Result := TRttiPointerType.Create(ATypeInfo);
|
||||
tkProcVar : Result := TRttiProcedureType.Create(ATypeInfo);
|
||||
tkMethod : Result := TRttiMethodType.Create(ATypeInfo);
|
||||
else
|
||||
Result := TRttiType.Create(ATypeInfo);
|
||||
end;
|
||||
@ -1212,6 +1260,43 @@ begin
|
||||
FVmtMethodParam := AVmtMethodParam;
|
||||
end;
|
||||
|
||||
{ TRttiMethodTypeParameter }
|
||||
|
||||
function TRttiMethodTypeParameter.GetHandle: Pointer;
|
||||
begin
|
||||
Result := fHandle;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetName: String;
|
||||
begin
|
||||
Result := fName;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetFlags: TParamFlags;
|
||||
begin
|
||||
Result := fFlags;
|
||||
end;
|
||||
|
||||
function TRttiMethodTypeParameter.GetParamType: TRttiType;
|
||||
var
|
||||
context: TRttiContext;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
Result := context.GetType(FType);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TRttiMethodTypeParameter.Create(aHandle: Pointer; const aName: String; aFlags: TParamFlags; aType: PTypeInfo);
|
||||
begin
|
||||
fHandle := aHandle;
|
||||
fName := aName;
|
||||
fFlags := aFlags;
|
||||
fType := aType;
|
||||
end;
|
||||
|
||||
{ TRttiIntfMethod }
|
||||
|
||||
function TRttiIntfMethod.GetHandle: Pointer;
|
||||
@ -2235,6 +2320,199 @@ begin
|
||||
Result := GetParameters(False);
|
||||
end;
|
||||
|
||||
{ TRttiInvokableType }
|
||||
|
||||
function TRttiInvokableType.GetParameters: specialize TArray<TRttiParameter>;
|
||||
begin
|
||||
Result := GetParameters(False);
|
||||
end;
|
||||
|
||||
{ TRttiMethodType }
|
||||
|
||||
function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
|
||||
type
|
||||
TParamInfo = record
|
||||
Handle: Pointer;
|
||||
Flags: TParamFlags;
|
||||
Name: String;
|
||||
end;
|
||||
|
||||
PParamFlags = ^TParamFlags;
|
||||
PCallConv = ^TCallConv;
|
||||
PPPTypeInfo = ^PPTypeInfo;
|
||||
|
||||
var
|
||||
infos: array of TParamInfo;
|
||||
total, visible, i: SizeInt;
|
||||
ptr: PByte;
|
||||
paramtypes: PPPTypeInfo;
|
||||
context: TRttiContext;
|
||||
obj: TRttiObject;
|
||||
begin
|
||||
if aWithHidden and (Length(FParamsAll) > 0) then
|
||||
Exit(FParamsAll);
|
||||
if not aWithHidden and (Length(FParams) > 0) then
|
||||
Exit(FParams);
|
||||
|
||||
ptr := @FTypeData^.ParamList[0];
|
||||
visible := 0;
|
||||
total := 0;
|
||||
|
||||
if FTypeData^.ParamCount > 0 then begin
|
||||
SetLength(infos, FTypeData^.ParamCount);
|
||||
|
||||
while total < FTypeData^.ParamCount do begin
|
||||
infos[total].Handle := ptr;
|
||||
infos[total].Flags := PParamFlags(ptr)^;
|
||||
Inc(ptr, SizeOf(TParamFlags));
|
||||
{ handle name }
|
||||
infos[total].Name := PShortString(ptr)^;
|
||||
Inc(ptr, ptr^ + SizeOf(Byte));
|
||||
{ skip type name }
|
||||
Inc(ptr, ptr^ + SizeOf(Byte));
|
||||
{ align? }
|
||||
if not (pfHidden in infos[total].Flags) then
|
||||
Inc(visible);
|
||||
Inc(total);
|
||||
end;
|
||||
end;
|
||||
|
||||
if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
|
||||
{ skip return type name }
|
||||
ptr := AlignTypeData(PByte(ptr) + ptr^ + SizeOf(Byte));
|
||||
{ handle return type }
|
||||
FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
|
||||
Inc(ptr, SizeOf(PPTypeInfo));
|
||||
end;
|
||||
|
||||
{ handle calling convention }
|
||||
FCallConv := PCallConv(ptr)^;
|
||||
Inc(ptr, SizeOf(TCallConv));
|
||||
|
||||
SetLength(FParamsAll, FTypeData^.ParamCount);
|
||||
SetLength(FParams, visible);
|
||||
|
||||
if FTypeData^.ParamCount > 0 then begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
paramtypes := PPPTypeInfo(ptr);
|
||||
visible := 0;
|
||||
for i := 0 to FTypeData^.ParamCount - 1 do begin
|
||||
obj := context.GetByHandle(infos[i].Handle);
|
||||
if Assigned(obj) then
|
||||
FParamsAll[i] := obj as TRttiMethodTypeParameter
|
||||
else begin
|
||||
FParamsAll[i] := TRttiMethodTypeParameter.Create(infos[i].Handle, infos[i].Name, infos[i].Flags, paramtypes[i]^);
|
||||
context.AddObject(FParamsAll[i]);
|
||||
end;
|
||||
|
||||
if not (pfHidden in infos[i].Flags) then begin
|
||||
FParams[visible] := FParamsAll[i];
|
||||
Inc(visible);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
if aWithHidden then
|
||||
Result := FParamsAll
|
||||
else
|
||||
Result := FParams;
|
||||
end;
|
||||
|
||||
function TRttiMethodType.GetCallingConvention: TCallConv;
|
||||
begin
|
||||
{ the calling convention is located after the parameters, so get the parameters
|
||||
which will also initialize the calling convention }
|
||||
GetParameters(True);
|
||||
Result := FCallConv;
|
||||
end;
|
||||
|
||||
function TRttiMethodType.GetReturnType: TRttiType;
|
||||
begin
|
||||
if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
|
||||
{ the return type is located after the parameters, so get the parameters
|
||||
which will also initialize the return type }
|
||||
GetParameters(True);
|
||||
Result := FReturnType;
|
||||
end else
|
||||
Result := Nil;
|
||||
end;
|
||||
|
||||
{ TRttiProcedureType }
|
||||
|
||||
function TRttiProcedureType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
|
||||
var
|
||||
visible, i: SizeInt;
|
||||
param: PProcedureParam;
|
||||
obj: TRttiObject;
|
||||
context: TRttiContext;
|
||||
begin
|
||||
if aWithHidden and (Length(FParamsAll) > 0) then
|
||||
Exit(FParamsAll);
|
||||
if not aWithHidden and (Length(FParams) > 0) then
|
||||
Exit(FParams);
|
||||
|
||||
if FTypeData^.ProcSig.ParamCount = 0 then
|
||||
Exit(Nil);
|
||||
|
||||
SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
|
||||
SetLength(FParams, FTypeData^.ProcSig.ParamCount);
|
||||
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
param := AlignTypeData(PProcedureParam(@FTypeData^.ProcSig.ParamCount + SizeOf(FTypeData^.ProcSig.ParamCount)));
|
||||
visible := 0;
|
||||
for i := 0 to FTypeData^.ProcSig.ParamCount - 1 do begin
|
||||
obj := context.GetByHandle(param);
|
||||
if Assigned(obj) then
|
||||
FParamsAll[i] := obj as TRttiMethodTypeParameter
|
||||
else begin
|
||||
FParamsAll[i] := TRttiMethodTypeParameter.Create(param, param^.Name, param^.ParamFlags, param^.ParamType);
|
||||
context.AddObject(FParamsAll[i]);
|
||||
end;
|
||||
|
||||
if not (pfHidden in param^.ParamFlags) then begin
|
||||
FParams[visible] := FParamsAll[i];
|
||||
Inc(visible);
|
||||
end;
|
||||
|
||||
param := PProcedureParam(AlignTypeData(PByte(@param^.Name) + Length(param^.Name) + SizeOf(param^.Name[0])));
|
||||
end;
|
||||
|
||||
SetLength(FParams, visible);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
|
||||
if aWithHidden then
|
||||
Result := FParamsAll
|
||||
else
|
||||
Result := FParams;
|
||||
end;
|
||||
|
||||
function TRttiProcedureType.GetCallingConvention: TCallConv;
|
||||
begin
|
||||
Result := FTypeData^.ProcSig.CC;
|
||||
end;
|
||||
|
||||
function TRttiProcedureType.GetReturnType: TRttiType;
|
||||
var
|
||||
context: TRttiContext;
|
||||
begin
|
||||
if not Assigned(FTypeData^.ProcSig.ResultTypeRef) then
|
||||
Exit(Nil);
|
||||
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
Result := context.GetType(FTypeData^.ProcSig.ResultTypeRef^);
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TRttiStringType }
|
||||
|
||||
function TRttiStringType.GetStringKind: TRttiStringKind;
|
||||
|
||||
@ -70,6 +70,9 @@ type
|
||||
{$ifdef fpc}
|
||||
procedure TestInterfaceRaw;
|
||||
{$endif}
|
||||
|
||||
procedure TestProcVar;
|
||||
procedure TestMethod;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -155,7 +158,11 @@ type
|
||||
TTestSet = set of TTestEnum;
|
||||
|
||||
TTestProc = procedure;
|
||||
TTestFunc1 = function: LongInt;
|
||||
TTestFunc2 = function(aArg1: LongInt; aArg2: array of LongInt): String;
|
||||
TTestMethod = procedure of object;
|
||||
TTestMethod1 = function: LongInt of object;
|
||||
TTestMethod2 = function(aArg1: LongInt; aArg2: array of LongInt): String of object;
|
||||
TTestHelper = class helper for TObject
|
||||
end;
|
||||
|
||||
@ -1548,6 +1555,111 @@ begin
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestProcVar;
|
||||
var
|
||||
context: TRttiContext;
|
||||
t: TRttiType;
|
||||
p: TRttiProcedureType;
|
||||
params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestProc)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(not Assigned(p.ReturnType), 'Return type is assigned');
|
||||
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(p.ReturnType), 'Return type is not assigned');
|
||||
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
|
||||
CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
|
||||
|
||||
p := t as TRttiProcedureType;
|
||||
Check(p.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(p.ReturnType), 'Return type is not assigned');
|
||||
Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
|
||||
|
||||
params := p.GetParameters;
|
||||
CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters');
|
||||
|
||||
Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
|
||||
//Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
|
||||
Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
|
||||
Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase1.TestMethod;
|
||||
var
|
||||
context: TRttiContext;
|
||||
t: TRttiType;
|
||||
m: TRttiMethodType;
|
||||
params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
|
||||
begin
|
||||
context := TRttiContext.Create;
|
||||
try
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(not Assigned(m.ReturnType), 'Return type is assigned');
|
||||
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(m.ReturnType), 'Return type is not assigned');
|
||||
//Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
|
||||
CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
|
||||
|
||||
t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2)));
|
||||
Check(Assigned(t), 'Rtti Type is Nil');
|
||||
Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
|
||||
Check(t is TRttiMethodType, 'Rtti Type is not a method type');
|
||||
|
||||
m := t as TRttiMethodType;
|
||||
Check(m.CallingConvention = ccReg, 'Calling convention does not match');
|
||||
Check(Assigned(m.ReturnType), 'Return type is not assigned');
|
||||
Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');
|
||||
|
||||
params := m.GetParameters;
|
||||
CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters');
|
||||
|
||||
Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
|
||||
//Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
|
||||
Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
|
||||
Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
|
||||
finally
|
||||
context.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif}
|
||||
|
||||
initialization
|
||||
|
||||
Loading…
Reference in New Issue
Block a user