From 7bb147dce08240f6eeb530bb97e749cae8d2e61e Mon Sep 17 00:00:00 2001 From: svenbarth Date: Sun, 7 Oct 2018 12:25:42 +0000 Subject: [PATCH] + add TRttiMethodType for method variables and TRttiProcedureType for procedure variables git-svn-id: trunk@39888 - --- packages/rtl-objpas/src/inc/rtti.pp | 278 +++++++++++++++++++++++ packages/rtl-objpas/tests/tests.rtti.pas | 112 +++++++++ 2 files changed, 390 insertions(+) diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index eb79f9c7ba..53d5fd6381 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -294,6 +294,37 @@ type function ToString: String; override; end; + TRttiInvokableType = class(TRttiType) + protected + function GetParameters(aWithHidden: Boolean): specialize TArray; virtual; abstract; + function GetCallingConvention: TCallConv; virtual; abstract; + function GetReturnType: TRttiType; virtual; abstract; + public + function GetParameters: specialize TArray; inline; + property CallingConvention: TCallConv read GetCallingConvention; + property ReturnType: TRttiType read GetReturnType; + end; + + TRttiMethodType = class(TRttiInvokableType) + private + FCallConv: TCallConv; + FReturnType: TRttiType; + FParams, FParamsAll: specialize TArray; + protected + function GetParameters(aWithHidden: Boolean): specialize TArray; override; + function GetCallingConvention: TCallConv; override; + function GetReturnType: TRttiType; override; + end; + + TRttiProcedureType = class(TRttiInvokableType) + private + FParams, FParamsAll: specialize TArray; + protected + function GetParameters(aWithHidden: Boolean): specialize TArray; 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; +begin + Result := GetParameters(False); +end; + +{ TRttiMethodType } + +function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray; +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; +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; diff --git a/packages/rtl-objpas/tests/tests.rtti.pas b/packages/rtl-objpas/tests/tests.rtti.pas index 815da9c1d7..7fd693fceb 100644 --- a/packages/rtl-objpas/tests/tests.rtti.pas +++ b/packages/rtl-objpas/tests/tests.rtti.pas @@ -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; +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; +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