Browse Source

+ add Delphi-compatible overload for TRttiInvokableType.CreateImplementation (at the same time also provides a more correct implementation of the TCallback one)

Sven/Sarah Barth 1 month ago
parent
commit
0fe6f3116c
1 changed files with 15 additions and 1 deletions
  1. 15 1
      packages/rtl-objpas/src/inc/rtti.pp

+ 15 - 1
packages/rtl-objpas/src/inc/rtti.pp

@@ -685,6 +685,7 @@ type
     property ReturnType: TRttiType read GetReturnType;
     function Invoke(const aProcOrMeth: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
     function CreateImplementation(aCallback: TCallback): TMethodImplementation;
+    function CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
     function ToString : string; override;
   end;
 
@@ -6162,6 +6163,19 @@ begin
 end;
 
 function TRttiInvokableType.CreateImplementation(aCallback: TCallback): TMethodImplementation;
+
+  procedure SelfCallback(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
+  begin
+    aCallback(TRttiInvokableType(aUserData), aArgs, aResult);
+  end;
+
+begin
+  if not Assigned(aCallback) then
+    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
+  Result := CreateImplementation(Self, @SelfCallback);
+end;
+
+function TRttiInvokableType.CreateImplementation(aUserData: Pointer; aCallback: TMethodImplementationCallback): TMethodImplementation;
 var
   params: TRttiParameterArray;
   args: specialize TArray<TFunctionCallParameterInfo>;
@@ -6194,7 +6208,7 @@ begin
   else
     res := Nil;
 
-  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, Self, TMethodImplementationCallback(aCallback));
+  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, aUserData, aCallback);
 end;
 
 function TRttiInvokableType.ToString: string;