* Allow to call constructor using Invoke()

packages/rtl-objpas/src/inc/rtti.pp

@@ -1209,12 +1209,15 @@ type
   { TRttiInstanceMethod }
 
   TRttiInstanceMethod = class(TRttiMethod)
+  Type
+    TStaticMethod = (smCalc, smFalse, smTrue);
   private
     FHandle: PVmtMethodExEntry;
     // False: without hidden, true: with hidden
     FParams : Array [Boolean] of TRttiParameterArray;
     FAttributesResolved: boolean;
     FAttributes: TCustomAttributeArray;
+    FStaticCalculated : TStaticMethod;
     procedure ResolveParams;
     procedure ResolveAttributes;
   protected
@@ -1784,7 +1787,7 @@ end;
 
 function TRttiInstanceMethod.GetHasExtendedInfo: Boolean;
 begin
-  Result:=inherited GetHasExtendedInfo;
+  Result:=True;
 end;
 
 function TRttiInstanceMethod.GetIsClassMethod: Boolean;
@@ -1803,9 +1806,23 @@ begin
 end;
 
 function TRttiInstanceMethod.GetIsStatic: Boolean;
+
+var
+  I : integer;
+
 begin
-  // ?
-  Result:=False;
+  if FStaticCalculated=smCalc then
+    begin
+    FStaticCalculated:=smTrue;
+    I:=0;
+    While (FStaticCalculated=smTrue) and (I<FHandle^.ParamCount) do
+      begin
+      if ((FHandle^.Param[i]^.Flags * [pfSelf,pfVmt])<>[]) then
+        FStaticCalculated:=smFalse;
+      Inc(I);
+      end;
+    end;
+  Result:=(FStaticCalculated=smTrue);
 end;
 
 function TRttiInstanceMethod.GetMethodKind: TMethodKind;
@@ -4290,6 +4307,9 @@ var
   resptr: Pointer;
   mgr: TFunctionCallManager;
   flags: TFunctionCallFlags;
+  hiddenVmt : Pointer;
+  S : String;
+
 begin
   mgr := FuncCallMgr[aCallConv];
   if not Assigned(mgr.Invoke) then
@@ -4301,6 +4321,8 @@ begin
   unhidden := 0;
   highs := 0;
   for param in aParams do begin
+    S:=Param.Name;
+    Writeln(S);
     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
@@ -4348,6 +4370,14 @@ begin
     if pfHidden in param.Flags then begin
       if pfSelf in param.Flags then
         args[i].ValueRef := aInstance.GetReferenceToRawData
+      else if pfVmt in param.Flags then
+        begin
+        if aInstance.Kind=tkClassRef then
+          hiddenVmt:=aInstance.AsClass
+        else if aInstance.Kind=tkClass then
+          hiddenVmt:=aInstance.AsObject.ClassType;
+        args[i].ValueRef := @HiddenVmt;
+        end
       else if pfResult in param.Flags then begin
         if not Assigned(restype) then
           raise EInvocationError.CreateFmt(SErrInvokeRttiDataError, [aName]);
@@ -4646,7 +4676,7 @@ begin
   if not Assigned(FVmtMethodParam^.ParamType) then
     Exit(Nil);
 
-  context := TRttiContext.Create;
+  context := TRttiContext.Create(FUsePublishedOnly);
   try
     Result := context.GetType(FVmtMethodParam^.ParamType^);
   finally
@@ -4686,7 +4716,7 @@ function TRttiMethodTypeParameter.GetParamType: TRttiType;
 var
   context: TRttiContext;
 begin
-  context := TRttiContext.Create;
+  context := TRttiContext.Create(FUsePublishedOnly);
   try
     Result := context.GetType(FType);
   finally
@@ -5256,9 +5286,10 @@ begin
     raise EInvocationError.CreateFmt(SErrInvokeClassMethodClassSelf, [Name]);
 
   addr := Nil;
-  if IsStatic then
+  if IsStatic or (GetVirtualIndex=-1) then
     addr := CodeAddress
-  else begin
+  else
+    begin
     vmt := Nil;
     if aInstance.Kind in [tkInterface, tkInterfaceRaw] then
       vmt := PCodePointer(PPPointer(aInstance.GetReferenceToRawData)^^);
@@ -5622,7 +5653,7 @@ begin
   SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
   SetLength(FParams, FTypeData^.ProcSig.ParamCount);
 
-  context := TRttiContext.Create;
+  context := TRttiContext.Create(FUsePublishedOnly);
   try
     param := AlignToPtr(PProcedureParam(@FTypeData^.ProcSig.ParamCount + SizeOf(FTypeData^.ProcSig.ParamCount)));
     visible := 0;
@@ -6002,9 +6033,8 @@ Var
 
 begin
   tbl:=Nil;
-  Ctx:=TRttiContext.Create;
+  Ctx:=TRttiContext.Create(FUsePublishedOnly);
   try
-    Ctx.UsePublishedOnly:=False;
     FMethodsResolved:=True;
     Len:=GetMethodList(FTypeInfo,Tbl,[],False);
     if not FUsePublishedOnly then

packages/rtl-objpas/tests/tests.rtti.invoke.pas

@@ -274,6 +274,19 @@ type
     Procedure Test9;
   end;
 
+  { TTestInvokeInstanceMethods }
+
+  TTestInvokeInstanceMethods = Class(TTestInvokeBase)
+  private
+    Fctx: TRttiContext;
+    function CreateClass(C: TClass): TObject;
+  Protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  Published
+    Procedure TestInvokeConstructor;
+  end;
+
 implementation
 
 { ----------------------------------------------------------------------
@@ -2703,7 +2716,60 @@ begin
     ]);
 end;
 
+{ TTestInvokeInstanceMethods }
+
+
+
+function TTestInvokeInstanceMethods.CreateClass(C : TClass) : TObject;
+
+var
+  t: TRttiType;
+  m: TRttiMethod;
+  V : TValue;
+  IT : ITestMethodCall;
+
+begin
+  t := FCtx.GetType(C);
+  CheckNotNull(T,'No type info');
+  M := T.GetMethod('create');
+  CheckNotNull(M,'No method info');
+  IT:=TTest.Create;
+  Result:=C.NewInstance;
+  {$IFDEF FPC}
+  TValue.Make(@IT,TypeInfo(ITestMethodCall),V);
+  {$ELSE}
+  TValue.Make<ITestMethodCall>(IT,V);
+  {$ENDIF}
+  M.Invoke(Result,[V]);
+end;
+
+procedure TTestInvokeInstanceMethods.SetUp;
+begin
+  inherited SetUp;
+  FCtx:=TRttiContext.Create(False);
+end;
+
+procedure TTestInvokeInstanceMethods.TearDown;
+begin
+  FCtx.Free;
+  inherited TearDown;
+end;
+
+procedure TTestInvokeInstanceMethods.TestInvokeConstructor;
 
+var
+  O : TObject;
+  P : TTestParent;
+  S : TTestConstructorCall;
+
+begin
+  O:=CreateClass(TTestConstructorCall);
+  CheckEquals(TTestConstructorCall,O.ClassType,'Correct class');
+  S:=O as TTestConstructorCall;
+  CheckEquals('In test',S.DoTest,'Correct result when called as correctly typed class');
+  P:=O as TTestParent;
+  CheckEquals('In test',P.DoTest,'Correct result when called as parent class');
+end;
 
 begin
 {$ifdef fpc}
@@ -2717,7 +2783,7 @@ begin
   RegisterTest(TTestInvokeTestProc);
   RegisterTest(TTestInvokeTestProcRecs);
   RegisterTest(TTestInvokeUntyped);
-
+  RegisterTest(TTestInvokeInstanceMethods);
 {$else fpc}
   RegisterTest(TTestInvoke.Suite);
   RegisterTest(TTestInvokeIntfMethods.Suite);
@@ -2729,6 +2795,7 @@ begin
   RegisterTest(TTestInvokeTestProc.Suite);
   RegisterTest(TTestInvokeTestProcRecs.Suite);
   RegisterTest(TTestInvokeUntyped.Suite);
+  RegisterTest(TTestInvokeInstanceMethods.Suite);
 {$endif fpc}
 end.
 

packages/rtl-objpas/tests/tests.rtti.invoketypes.pas

@@ -247,6 +247,36 @@ type
     RecSizeMarker = SizeInt($80000000);
   end;
 
+  ITestMethodCall = interface
+    Function Test : String;
+  end;
+
+{$RTTI EXPLICIT METHODS[vcPrivate,vcProtected,vcPublic,vcPublished]}
+
+  { TTestParent }
+
+  TTestParent = class
+    function DoTest : String; virtual;
+  end;
+
+  TTest = Class(TInterfacedObject,ITestMethodCall)
+    FTestCalled : Boolean;
+    Function Test : String;
+  end;
+
+  { TTestConstructorCall }
+
+  TTestConstructorCall = class(TTestParent)
+  Private
+    FTest : ITestMethodCall;
+  Public
+    constructor Create({[QueryParam]} aTest: ITestMethodCall);
+    function DoTest : String; override;
+  end;
+
+
+
+
   TMethodTest1 = procedure of object;
   TMethodTest2 = function: SizeInt of object;
   TMethodTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object;
@@ -924,6 +954,13 @@ begin
   inherited Destroy;
 end;
 
+{ TTestParent }
+
+function TTestParent.DoTest: String;
+begin
+  Result:='Parent';
+end;
+
 procedure ProcTest1;
 begin
   TTestInterfaceClass.ProcVarInst.Test1;
@@ -1090,6 +1127,24 @@ begin
 end;
 
 
+constructor TTestConstructorCall.Create(aTest: ITestMethodCall);
+begin
+  FTest:=aTest;
+end;
+
+function TTestConstructorCall.DoTest : string;
+begin
+  Result:=FTest.Test;
+end;
+
+{ TTest }
+
+function TTest.Test : string;
+begin
+  FTestCalled:=True;
+  Result:='In test';
+end;
+
 
 end.