diff --git a/packages/rtl-objpas/src/inc/rtti.pp b/packages/rtl-objpas/src/inc/rtti.pp index 0d71fc91bd..993b882bdf 100644 --- a/packages/rtl-objpas/src/inc/rtti.pp +++ b/packages/rtl-objpas/src/inc/rtti.pp @@ -2734,7 +2734,13 @@ Procedure TValue.CastEnumToEnum(out aRes : Boolean; out ADest: TValue; aDestType begin if aType^.Kind=tkEnumeration then - Result:=GetTypeData(aType)^.BaseType + begin + Result:=GetTypeData(aType)^.BaseType; + if Assigned(Result) and (Result^.Kind = tkEnumeration) then + Result := GetEnumBaseType(Result) + else + Result := aType; + end else Result:=Nil; end; @@ -3258,7 +3264,7 @@ Procedure TValue.CastFromInteger(out aRes : Boolean; out ADest: TValue; aDestTyp begin Case aDestType^.Kind of - tkChar: CastIntegerToInteger(aRes,aDest,aDestType); + tkInteger: CastIntegerToInteger(aRes,aDest,aDestType); tkVariant : CastToVariant(aRes,aDest,aDestType); tkInt64 : CastIntegerToInt64(aRes,aDest,aDestType); tkQWord : CastIntegerToQWord(aRes,aDest,aDestType); @@ -4437,17 +4443,22 @@ begin end; function Invoke(const aName: String; aCodeAddress: CodePointer; aCallConv: TCallConv; aStatic: Boolean; aInstance: TValue; constref aArgs: array of TValue; const aParams: TRttiParameterArray; aReturnType: TRttiType): TValue; + function ShouldTryCast(AParam: TRttiParameter; const AArg: TValue): boolean; + begin + Result := Assigned(AParam.ParamType) and (AParam.ParamType.FTypeInfo <> AArg.TypeInfo); + end; + var param: TRttiParameter; - unhidden, highs, i: SizeInt; + unhidden, i: SizeInt; args: TFunctionCallParameterArray; - highargs: array of SizeInt; + castedargs: array of TValue; // instance + args[i].Cast restype: PTypeInfo; resptr: Pointer; mgr: TFunctionCallManager; flags: TFunctionCallFlags; hiddenVmt : Pointer; - + highArg: SizeInt; begin mgr := FuncCallMgr[aCallConv]; if not Assigned(mgr.Invoke) then @@ -4456,22 +4467,17 @@ begin if not Assigned(aCodeAddress) then raise EInvocationError.CreateFmt(SErrInvokeNoCodeAddr, [aName]); + SetLength(castedargs, Length(aParams)); unhidden := 0; - highs := 0; for param in aParams do begin if unhidden < Length(aArgs) then begin if pfArray in param.Flags then begin if Assigned(aArgs[unhidden].TypeInfo) and not aArgs[unhidden].IsArray and (aArgs[unhidden].Kind <> param.ParamType.TypeKind) then raise EInvocationError.CreateFmt(SErrInvokeArrayArgExpected, [param.Name, aName]); - end else if not (pfHidden in param.Flags) then begin - if Assigned(param.ParamType) and (aArgs[unhidden].Kind <> param.ParamType.TypeKind) then - raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]); end; end; if not (pfHidden in param.Flags) then Inc(unhidden); - if pfHigh in param.Flags then - Inc(highs); end; if unhidden <> Length(aArgs) then @@ -4487,12 +4493,9 @@ begin restype := Nil; end; - highargs:=[]; args:=[]; - SetLength(highargs, highs); SetLength(args, Length(aParams)); unhidden := 0; - highs := 0; for i := 0 to High(aParams) do begin param := aParams[i]; @@ -4505,7 +4508,15 @@ begin if pfHidden in param.Flags then begin if pfSelf in param.Flags then - args[i].ValueRef := aInstance.GetReferenceToRawData + begin + if ShouldTryCast(param, aInstance) then + begin + if not aInstance.TryCast(param.ParamType.Handle, castedargs[I]) then + raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, ['Self', aName]); + args[i].ValueRef := castedargs[I].GetReferenceToRawData; + end else + args[i].ValueRef := aInstance.GetReferenceToRawData + end else if pfVmt in param.Flags then begin if aInstance.Kind=tkClassRef then @@ -4523,13 +4534,13 @@ begin end else if pfHigh in param.Flags then begin { the corresponding array argument is the *previous* unhidden argument } if aArgs[unhidden - 1].IsArray then - highargs[highs] := aArgs[unhidden - 1].GetArrayLength - 1 + highArg := aArgs[unhidden - 1].GetArrayLength - 1 else if not Assigned(aArgs[unhidden - 1].TypeInfo) then - highargs[highs] := -1 + highArg := -1 else - highargs[highs] := 0; - args[i].ValueRef := @highargs[highs]; - Inc(highs); + highArg := 0; + TValue.Make(@highArg, TypeInfo(SizeInt), castedargs[i]); + args[i].ValueRef := castedargs[i].GetReferenceToRawData; end; end else begin if (pfArray in param.Flags) then begin @@ -4540,7 +4551,22 @@ begin else args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; end else - args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData; + begin + if param.Flags * [pfVar, pfOut] <> [] then + begin + if ShouldTryCast(param, aArgs[unhidden]) then + raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]); + args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData + end + else if not ShouldTryCast(param, aArgs[unhidden]) then + args[i].ValueRef := aArgs[unhidden].GetReferenceToRawData + else + begin + if not aArgs[unhidden].TryCast(param.ParamType.Handle, castedargs[I]) then + raise EInvocationError.CreateFmt(SErrInvokeArgInvalidType, [param.Name, aName]); + args[i].ValueRef := castedargs[I].GetReferenceToRawData; + end; + end; Inc(unhidden); end; diff --git a/packages/rtl-objpas/tests/tests.rtti.invoke.pas b/packages/rtl-objpas/tests/tests.rtti.invoke.pas index 0af241996e..47e183f52a 100644 --- a/packages/rtl-objpas/tests/tests.rtti.invoke.pas +++ b/packages/rtl-objpas/tests/tests.rtti.invoke.pas @@ -68,6 +68,7 @@ type procedure TestIntfVariant; procedure TestTObject; + procedure TestCasts; end; { TTestInvokeIntfMethods } @@ -1494,6 +1495,57 @@ begin end; +procedure TTestInvoke.TestCasts; + +var + Context: TRttiContext; + + procedure ExpectedInvocationException(const AMethodName: string; + const AInstance: TValue; const AArgs: array of TValue); + var + HasException: boolean; + begin + HasException := False; + try + Context.GetType(TTestInvokeCast).GetMethod(AMethodName).Invoke(AInstance, AArgs); + except + {$ifndef fpc} + on EInvalidCast do + HasException := True; + {$endif} + on EInvocationError do + HasException := True; + end; + if not HasException then + Fail('Expected exception on call method ' + AMethodName); + end; + +var + Instance: TValue; + M: TRttiMethod; + T1,T2,TempV: TValue; + +begin + + Context := TRttiContext.Create; + try + Instance := TValue.specialize From(TTestInvokeCast.Create); + M := Context.GetType(TTestInvokeCast).GetMethod('Test'); + T1:=TValue.specialize From(10); + T2:=M.Invoke(Instance, [T1]); + CheckEquals(11, T2. specialize AsType, 'Test(Double(10) <> 11)'); + + ExpectedInvocationException('Test', TValue. specialize From(TObject.Create), [TValue. Specialize From(10)]); + ExpectedInvocationException('Test2', Instance, [TValue.specialize From(10)]); + + Context.GetType(TTestInvokeCast).GetMethod('Test3').Invoke(Instance, [TValue. specialize From(en1_1)]); + ExpectedInvocationException('Test3', Instance, [TValue. specialize From(en2_1)]); + + Instance. specialize AsType.Free; + finally + Context.Free; + end; +end; procedure TTestInvoke.TestTObject; @@ -1558,6 +1610,9 @@ begin DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls); end; + + + { ---------------------------------------------------------------------- TTestInvokeMethodTests ----------------------------------------------------------------------} diff --git a/packages/rtl-objpas/tests/tests.rtti.invoketypes.pas b/packages/rtl-objpas/tests/tests.rtti.invoketypes.pas index d0796de2ca..1d24909381 100644 --- a/packages/rtl-objpas/tests/tests.rtti.invoketypes.pas +++ b/packages/rtl-objpas/tests/tests.rtti.invoketypes.pas @@ -274,6 +274,21 @@ type function DoTest : String; override; end; +type + TEnum1 = (en1_1, en1_2); + TEnum2 = (en2_1); + TEnum3 = en1_1..en1_1; + + + { TTestInvokeCast } + + TTestInvokeCast = class(TPersistent) + published + function Test(Arg: Single): Double; + procedure Test2(var Arg: Single); + procedure Test3(Arg: TEnum1); + function Test4(Arg: UInt8): UInt8; + end; @@ -1145,6 +1160,27 @@ begin Result:='In test'; end; +{ TTestInvokeCast } + +function TTestInvokeCast.Test(Arg: Single): Double; +begin + Result := Arg + 1; +end; + +procedure TTestInvokeCast.Test2(var Arg: Single); +begin + Arg := Arg + 1; +end; + +procedure TTestInvokeCast.Test3(Arg: TEnum1); +begin + +end; + +function TTestInvokeCast.Test4(Arg: UInt8): UInt8; +begin + Result := Arg + 1; +end; end. diff --git a/packages/rtl-objpas/tests/tests.rtti.value.pas b/packages/rtl-objpas/tests/tests.rtti.value.pas index 1f7c54468a..abd701fe88 100644 --- a/packages/rtl-objpas/tests/tests.rtti.value.pas +++ b/packages/rtl-objpas/tests/tests.rtti.value.pas @@ -15,8 +15,8 @@ Type procedure TestDataSizeEmpty; procedure TestReferenceRawData; procedure TestReferenceRawDataEmpty; - procedure TestIsManaged; + procedure TestCasts; end; TTestValueSimple = Class(TTestCase) @@ -1878,6 +1878,31 @@ begin CheckEquals(false, IsManaged(nil), 'IsManaged for nil'); end; +Type + TEnum1 = (en1_1, en1_2); + TEnum2 = (en2_1); + TEnum3 = en1_1..en1_1; + +procedure TTestValueGeneral.TestCasts; + +var + TempV,T1,T2,T3 : TValue; + +begin + T1:=TValue. specialize From(en1_1); + T2:=T1. specialize Cast; +// T3:=T2. specialize AsType; + CheckTrue((en1_1 = T2. specialize AsType), 'en1_1 = (TValue.From(en1_1).Cast.AsType)'); + CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(AnsiChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(AnsiChar), V)'); + CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(WideChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(WideChar), V)'); +{$ifdef fpc} + CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(UnicodeChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(UnicodeChar), V)'); +{$endif} + CheckTrue(Byte(397) = (TValue. specialize From(397). specialize Cast(). specialize AsType), 'Byte(397) = (TValue.From(397).Cast().AsType)'); + CheckTrue(32 = (TValue. specialize From(32). specialize Cast(). specialize AsType), '32 = (TValue.From(32).Cast().AsType)'); +end; + + procedure TTestValueGeneral.TestReferenceRawData; var value: TValue; diff --git a/tests/webtbs/tw41030.pp b/tests/webtbs/tw41030.pp new file mode 100644 index 0000000000..70e94eeeaf --- /dev/null +++ b/tests/webtbs/tw41030.pp @@ -0,0 +1,123 @@ +program tw41030; +{$APPTYPE CONSOLE} +{$RTTI EXPLICIT METHODS([vcPublished]) PROPERTIES([vcPublished]) FIELDS([vcPublished])} +{$M+} +{$ifdef fpc} +{$mode DELPHI} +uses + SysUtils, TypInfo, Rtti {$ifndef WINDOWS} , ffi.manager {$endif} + ; +{$else} +{$R *.res} +uses + SysUtils, Rtti; +{$endif} + + +var ErrorCount: Integer = 0; + +procedure AddError(const AMsg: string); +begin + WriteLn(AMsg); + Inc(ErrorCount); +end; + +type + TEnum1 = (en1_1, en1_2); + TEnum2 = (en2_1); + TEnum3 = en1_1..en1_1; + + + { TTestObj } + + TTestObj = class + published + function Test(Arg: Single): Double; + procedure Test2(var Arg: Single); + procedure Test3(Arg: TEnum1); + function Test4(Arg: UInt8): UInt8; + end; + + +function TTestObj.Test(Arg: Single): Double; +begin + Result := Arg + 1; +end; + +procedure TTestObj.Test2(var Arg: Single); +begin + Arg := Arg + 1; +end; + +procedure TTestObj.Test3(Arg: TEnum1); +begin + +end; + +function TTestObj.Test4(Arg: UInt8): UInt8; +begin + Result := Arg + 1; +end; + +var + Context: TRttiContext; +procedure ExpectedInvocationException(const AMethodName: string; + const AInstance: TValue; const AArgs: array of TValue); +var + HasException: boolean; +begin + HasException := False; + try + Context.GetType(TTestObj).GetMethod(AMethodName).Invoke(AInstance, AArgs); + except +{$ifndef fpc} + on EInvalidCast do + HasException := True; +{$endif} + on EInvocationError do + HasException := True; + end; + if not HasException then + AddError('Expected exception on call method ' + AMethodName); +end; + +procedure Check(ACondition: boolean; const AMsg: string); +begin + if not ACondition then + AddError(AMsg); +end; + +var + Instance: TValue; + M: TRttiMethod; + TempV: TValue; +begin + Check(en1_1 = (TValue.From(en1_1).Cast.AsType), 'en1_1 = (TValue.From(en1_1).Cast.AsType)'); + Check(not (TValue.From(32).TryCast(TypeInfo(AnsiChar), TempV)), 'not (TValue.From(32).TryCast(TypeInfo(AnsiChar), V)'); + Check(not (TValue.From(32).TryCast(TypeInfo(WideChar), TempV)), 'not (TValue.From(32).TryCast(TypeInfo(WideChar), V)'); +{$ifdef fpc} + Check(not (TValue.From(32).TryCast(TypeInfo(UnicodeChar), TempV)), 'not (TValue.From(32).TryCast(TypeInfo(UnicodeChar), V)'); +{$endif} + Check(Byte(397) = (TValue.From(397).Cast().AsType), 'Byte(397) = (TValue.From(397).Cast().AsType)'); + Check(32 = (TValue.From(32).Cast().AsType), '32 = (TValue.From(32).Cast().AsType)'); + + Context := TRttiContext.Create; + Instance := TValue.From(TTestObj.Create); + M := Context.GetType(TTestObj).GetMethod('Test'); + if (M.Invoke(Instance, [TValue.From(10)]).AsType) <> 11 then + AddError('Test(Double(10) <> 11)'); + + ExpectedInvocationException('Test', TValue.From(TObject.Create), [TValue.From(10)]); + ExpectedInvocationException('Test2', Instance, [TValue.From(10)]); + + Context.GetType(TTestObj).GetMethod('Test3').Invoke(Instance, [TValue.From(en1_1)]); + ExpectedInvocationException('Test3', Instance, [TValue.From(en2_1)]); + + Instance.AsType.Free; + + Context.Free; + + if ErrorCount <> 0 then + Halt(ErrorCount); + WriteLn('OK'); +end. \ No newline at end of file