* Fix TValue casts, patch by Евгений Савин, fixes issue #41030

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<ParamType>
   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;

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>(TTestInvokeCast.Create);
+    M := Context.GetType(TTestInvokeCast).GetMethod('Test');
+    T1:=TValue.specialize From<Double>(10);
+    T2:=M.Invoke(Instance, [T1]);
+    CheckEquals(11, T2. specialize AsType<Double>, 'Test(Double(10) <> 11)');
+
+    ExpectedInvocationException('Test', TValue. specialize From<TObject>(TObject.Create), [TValue. Specialize From<Double>(10)]);
+    ExpectedInvocationException('Test2', Instance, [TValue.specialize From<Double>(10)]);
+
+    Context.GetType(TTestInvokeCast).GetMethod('Test3').Invoke(Instance, [TValue. specialize From<TEnum3>(en1_1)]);
+    ExpectedInvocationException('Test3', Instance, [TValue. specialize From<TEnum2>(en2_1)]);
+
+    Instance. specialize AsType<TTestInvokeCast>.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
   ----------------------------------------------------------------------}

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.
 

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<TEnum1>(en1_1);
+  T2:=T1. specialize Cast<TEnum3>;
+//  T3:=T2. specialize AsType<TEnum3>;
+  CheckTrue((en1_1 = T2. specialize AsType<TEnum3>), 'en1_1 = (TValue.From<TEnum1>(en1_1).Cast<TEnum3>.AsType<TEnum3>)');
+  CheckFalse(TValue. specialize From<Integer>(32).TryCast(TypeInfo(AnsiChar), TempV), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(AnsiChar), V)');
+  CheckFalse(TValue. specialize From<Integer>(32).TryCast(TypeInfo(WideChar), TempV), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(WideChar), V)');
+{$ifdef fpc}
+  CheckFalse(TValue. specialize From<Integer>(32).TryCast(TypeInfo(UnicodeChar), TempV), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(UnicodeChar), V)');
+{$endif}
+  CheckTrue(Byte(397) = (TValue. specialize From<Integer>(397). specialize Cast<Byte>(). specialize AsType<Byte>), 'Byte(397) = (TValue.From<Integer>(397).Cast<Byte>().AsType<Byte>)');
+  CheckTrue(32 = (TValue. specialize From<Byte>(32). specialize Cast<Integer>(). specialize AsType<Integer>), '32 = (TValue.From<Byte>(32).Cast<Integer>().AsType<Integer>)');
+end;
+  
+
 procedure TTestValueGeneral.TestReferenceRawData;
 var
   value: TValue;

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<TEnum1>(en1_1).Cast<TEnum3>.AsType<TEnum3>), 'en1_1 = (TValue.From<TEnum1>(en1_1).Cast<TEnum3>.AsType<TEnum3>)');
+  Check(not (TValue.From<Integer>(32).TryCast(TypeInfo(AnsiChar), TempV)), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(AnsiChar), V)');
+  Check(not (TValue.From<Integer>(32).TryCast(TypeInfo(WideChar), TempV)), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(WideChar), V)');
+{$ifdef fpc}
+  Check(not (TValue.From<Integer>(32).TryCast(TypeInfo(UnicodeChar), TempV)), 'not (TValue.From<Integer>(32).TryCast(TypeInfo(UnicodeChar), V)');
+{$endif}
+  Check(Byte(397) = (TValue.From<Integer>(397).Cast<Byte>().AsType<Byte>), 'Byte(397) = (TValue.From<Integer>(397).Cast<Byte>().AsType<Byte>)');
+  Check(32 = (TValue.From<Byte>(32).Cast<Integer>().AsType<Integer>), '32 = (TValue.From<Byte>(32).Cast<Integer>().AsType<Integer>)');
+
+  Context := TRttiContext.Create;
+  Instance := TValue.From<TTestObj>(TTestObj.Create);
+  M := Context.GetType(TTestObj).GetMethod('Test');
+  if (M.Invoke(Instance, [TValue.From<Double>(10)]).AsType<Double>) <> 11 then
+    AddError('Test(Double(10) <> 11)');
+
+  ExpectedInvocationException('Test', TValue.From<TObject>(TObject.Create), [TValue.From<Double>(10)]);
+  ExpectedInvocationException('Test2', Instance, [TValue.From<Double>(10)]);
+
+  Context.GetType(TTestObj).GetMethod('Test3').Invoke(Instance, [TValue.From<TEnum3>(en1_1)]);
+  ExpectedInvocationException('Test3', Instance, [TValue.From<TEnum2>(en2_1)]);
+
+  Instance.AsType<TTestObj>.Free;
+
+  Context.Free;
+
+  if ErrorCount <> 0 then
+    Halt(ErrorCount);
+  WriteLn('OK');
+end.