# revisions: 40660,40661,40662,40663,40664,40665,40666,40667,40668,40669,40670,40673,40692,40693,40694,40695,40696,40697,40698,40699,40700

git-svn-id: branches/fixes_3_2@43397 -

.gitattributes

@@ -7584,8 +7584,10 @@ packages/rtl-objpas/src/inc/widestrutils.pp svneol=native#text/plain
 packages/rtl-objpas/src/win/varutils.pp svneol=native#text/plain
 packages/rtl-objpas/src/x86_64/invoke.inc svneol=native#text/plain
 packages/rtl-objpas/tests/testrunner.rtlobjpas.pp svneol=native#text/pascal
+packages/rtl-objpas/tests/tests.rtti.impl.pas svneol=native#text/pascal
 packages/rtl-objpas/tests/tests.rtti.invoke.pas svneol=native#text/pascal
 packages/rtl-objpas/tests/tests.rtti.pas svneol=native#text/plain
+packages/rtl-objpas/tests/tests.rtti.util.pas svneol=native#text/pascal
 packages/rtl-unicode/Makefile svneol=native#text/plain
 packages/rtl-unicode/Makefile.fpc svneol=native#text/plain
 packages/rtl-unicode/fpmake.pp svneol=native#text/plain
@@ -16393,6 +16395,8 @@ tests/webtbs/tw3443.pp svneol=native#text/plain
 tests/webtbs/tw34438.pp svneol=native#text/pascal
 tests/webtbs/tw3444.pp svneol=native#text/plain
 tests/webtbs/tw34442.pp svneol=native#text/plain
+tests/webtbs/tw34496.pp svneol=native#text/pascal
+tests/webtbs/tw34509.pp svneol=native#text/pascal
 tests/webtbs/tw3456.pp svneol=native#text/plain
 tests/webtbs/tw3457.pp svneol=native#text/plain
 tests/webtbs/tw3460.pp svneol=native#text/plain

packages/libffi/src/ffi.manager.pp

@@ -500,7 +500,6 @@ const
     Invoke: @FFIInvoke;
     CreateCallbackProc: Nil;
     CreateCallbackMethod: Nil;
-    FreeCallback: Nil
   );
 
 var

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

@@ -16,6 +16,7 @@ unit Rtti experimental;
 
 {$mode objfpc}{$H+}
 {$modeswitch advancedrecords}
+{$Assertions on}
 
 { Note: since the Lazarus IDE is not yet capable of correctly handling generic
   functions it is best to define a InLazIDE define inside the IDE that disables
@@ -47,6 +48,24 @@ type
   TRttiProperty = class;
   TRttiInstanceType = class;
 
+  TFunctionCallCallback = class
+  protected
+    function GetCodeAddress: CodePointer; virtual; abstract;
+  public
+    property CodeAddress: CodePointer read GetCodeAddress;
+  end;
+
+  TFunctionCallFlag = (
+    fcfStatic
+  );
+  TFunctionCallFlags = set of TFunctionCallFlag;
+
+  TFunctionCallParameterInfo = record
+    ParamType: PTypeInfo;
+    ParamFlags: TParamFlags;
+    ParaLocs: PParameterLocations;
+  end;
+
   IValueData = interface
   ['{1338B2F3-2C21-4798-A641-CA2BC5BF2396}']
     procedure ExtractRawData(ABuffer: pointer);
@@ -125,6 +144,8 @@ type
     function IsType(ATypeInfo: PTypeInfo): boolean; inline;
     function TryAsOrdinal(out AResult: int64): boolean;
     function GetReferenceToRawData: Pointer;
+    procedure ExtractRawData(ABuffer: Pointer);
+    procedure ExtractRawDataNoCopy(ABuffer: Pointer);
     class operator := (const AValue: String): TValue; inline;
     class operator := (AValue: LongInt): TValue; inline;
     class operator := (AValue: Single): TValue; inline;
@@ -294,16 +315,48 @@ type
     function ToString: String; override;
   end;
 
+  TMethodImplementationCallbackMethod = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue) of object;
+  TMethodImplementationCallbackProc = procedure(aUserData: Pointer; const aArgs: TValueArray; out aResult: TValue);
+
+  TMethodImplementation = class
+  private
+    fLowLevelCallback: TFunctionCallCallback;
+    fCallbackProc: TMethodImplementationCallbackProc;
+    fCallbackMethod: TMethodImplementationCallbackMethod;
+    fArgs: specialize TArray<TFunctionCallParameterInfo>;
+    fArgLen: SizeInt;
+    fRefArgs: specialize TArray<SizeInt>;
+    fFlags: TFunctionCallFlags;
+    fResult: PTypeInfo;
+    fCC: TCallConv;
+    function GetCodeAddress: CodePointer;
+    procedure InitArgs;
+    procedure HandleCallback(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+    constructor Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod);
+    constructor Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackProc);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    property CodeAddress: CodePointer read GetCodeAddress;
+  end;
+
   TRttiInvokableType = class(TRttiType)
   protected
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; virtual; abstract;
     function GetCallingConvention: TCallConv; virtual; abstract;
     function GetReturnType: TRttiType; virtual; abstract;
+    function GetFlags: TFunctionCallFlags; virtual; abstract;
+  public type
+    TCallbackMethod = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue) of object;
+    TCallbackProc = procedure(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
   public
     function GetParameters: specialize TArray<TRttiParameter>; inline;
     property CallingConvention: TCallConv read GetCallingConvention;
     property ReturnType: TRttiType read GetReturnType;
     function Invoke(const aProcOrMeth: TValue; const aArgs: array of TValue): TValue; virtual; abstract;
+    { Note: once "reference to" is supported these will be replaced by a single method }
+    function CreateImplementation(aCallback: TCallbackMethod): TMethodImplementation;
+    function CreateImplementation(aCallback: TCallbackProc): TMethodImplementation;
   end;
 
   TRttiMethodType = class(TRttiInvokableType)
@@ -315,6 +368,7 @@ type
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
     function GetCallingConvention: TCallConv; override;
     function GetReturnType: TRttiType; override;
+    function GetFlags: TFunctionCallFlags; override;
   public
     function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
   end;
@@ -326,6 +380,7 @@ type
     function GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>; override;
     function GetCallingConvention: TCallConv; override;
     function GetReturnType: TRttiType; override;
+    function GetFlags: TFunctionCallFlags; override;
   public
     function Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue; override;
   end;
@@ -429,12 +484,6 @@ type
   EInvocationError = class(Exception);
   ENonPublicType = class(Exception);
 
-  TFunctionCallParameterInfo = record
-    ParamType: PTypeInfo;
-    ParamFlags: TParamFlags;
-    ParaLocs: PParameterLocations;
-  end;
-
   TFunctionCallParameter = record
     ValueRef: Pointer;
     ValueSize: SizeInt;
@@ -442,22 +491,14 @@ type
   end;
   TFunctionCallParameterArray = specialize TArray<TFunctionCallParameter>;
 
-  TFunctionCallFlag = (
+  TFunctionCallProc = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
-    fcfStatic
+  TFunctionCallMethod = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer) of object;
-  );
-  TFunctionCallFlags = set of TFunctionCallFlag;
-
-  TFunctionCallCallback = Pointer;
-
-  TFunctionCallProc = procedure(const aArgs: TValueArray; out aResult: TValue; aContext: Pointer);
-  TFunctionCallMethod = procedure(const aArgs: TValueArray; out aResult: TValue; aContext: Pointer) of object;
 
   TFunctionCallManager = record
     Invoke: procedure(CodeAddress: CodePointer; const Args: TFunctionCallParameterArray; CallingConvention: TCallConv;
               ResultType: PTypeInfo; ResultValue: Pointer; Flags: TFunctionCallFlags);
-    CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+    CreateCallbackProc: function(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-    CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+    CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-    FreeCallback: procedure(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
   end;
   TFunctionCallManagerArray = array[TCallConv] of TFunctionCallManager;
 
@@ -478,9 +519,8 @@ procedure GetFunctionCallManagers(out aFuncCallMgrs: TFunctionCallManagerArray);
 function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray; aCallConv: TCallConv;
   aResultType: PTypeInfo; aIsStatic: Boolean; aIsConstructor: Boolean): TValue;
 
-function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
-procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
 
 function IsManaged(TypeInfo: PTypeInfo): boolean;
 
@@ -651,6 +691,10 @@ resourcestring
   SErrInvokeRttiDataError     = 'The RTTI data is inconsistent for method: %s';
   SErrInvokeCallableNotProc   = 'The callable value is not a procedure variable for: %s';
   SErrInvokeCallableNotMethod = 'The callable value is not a method variable for: %s';
+  SErrMethodImplNoCallback    = 'No callback specified for method implementation';
+  SErrMethodImplInsufficientRtti = 'Insufficient RTTI to create method implementation';
+  SErrMethodImplCreateFailed  = 'Failed to create method implementation';
+  SErrMethodImplCreateNoArg   = 'TMethodImplementation can not be created this way';
 
 var
   PoolRefCount : integer;
@@ -668,29 +712,23 @@ begin
   raise ENotImplemented.Create(SErrInvokeNotImplemented);
 end;
 
-function NoCreateCallbackProc(aFunc: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function NoCreateCallbackProc(aFunc: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   Result := Nil;
   raise ENotImplemented.Create(SErrCallbackNotImplented);
 end;
 
-function NoCreateCallbackMethod(aFunc: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function NoCreateCallbackMethod(aFunc: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   Result := Nil;
   raise ENotImplemented.Create(SErrCallbackNotImplented);
 end;
 
-procedure NoFreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
-begin
-  raise ENotImplemented.Create(SErrCallbackNotImplented);
-end;
-
 const
   NoFunctionCallManager: TFunctionCallManager = (
     Invoke: @NoInvoke;
     CreateCallbackProc: @NoCreateCallbackProc;
     CreateCallbackMethod: @NoCreateCallbackMethod;
-    FreeCallback: @NoFreeCallback
   );
 
 procedure SetFunctionCallManager(aCallConv: TCallConv; constref aFuncCallMgr: TFunctionCallManager;
@@ -929,7 +967,7 @@ begin
   mgr.Invoke(aCodeAddress, args, aCallConv, restype, resptr, flags);
 end;
 
-function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   if not Assigned(FuncCallMgr[aCallConv].CreateCallbackProc) then
     raise ENotImplemented.Create(SErrCallbackNotImplented);
@@ -940,7 +978,7 @@ begin
   Result := FuncCallMgr[aCallConv].CreateCallbackProc(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
 end;
 
-function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 begin
   if not Assigned(FuncCallMgr[aCallConv].CreateCallbackMethod) then
     raise ENotImplemented.Create(SErrCallbackNotImplented);
@@ -951,12 +989,6 @@ begin
   Result := FuncCallMgr[aCallConv].CreateCallbackMethod(aHandler, aCallConv, aArgs, aResultType, aFlags, aContext);
 end;
 
-procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
-begin
-  if Assigned(FuncCallMgr[aCallConv].FreeCallback) then
-    FuncCallMgr[aCallConv].FreeCallback(aCallback, aCallConv);
-end;
-
 function IsManaged(TypeInfo: PTypeInfo): boolean;
 begin
   if Assigned(TypeInfo) then
@@ -1607,11 +1639,8 @@ begin
   { first handle those types that need a TValueData implementation }
   case ATypeInfo^.Kind of
     tkSString  : begin
-                   if Assigned(ABuffer) then
+                   td := GetTypeData(ATypeInfo);
-                     size := Length(PShortString(ABuffer)^) + 1
+                   result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, ATypeInfo, True);
-                   else
-                     size := 256;
-                   result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, size, ATypeInfo, True);
                  end;
     tkWString,
     tkUString,
@@ -1932,6 +1961,8 @@ begin
       ftSingle   : result := FData.FAsSingle;
       ftDouble   : result := FData.FAsDouble;
       ftExtended : result := FData.FAsExtended;
+      ftCurr     : result := FData.FAsCurr;
+      ftComp     : result := FData.FAsComp;
     else
       raise EInvalidCast.Create(SErrInvalidTypecast);
     end;
@@ -2046,7 +2077,11 @@ begin
       otULong:  Result := FData.FAsULong;
       otSQWord: Result := FData.FAsSInt64;
       otUQWord: Result := FData.FAsUInt64;
-    end;
+    end
+  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
+    Result := Int64(FData.FAsComp)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsUInt64: QWord;
@@ -2061,7 +2096,11 @@ begin
       otULong:  Result := FData.FAsULong;
       otSQWord: Result := FData.FAsSInt64;
       otUQWord: Result := FData.FAsUInt64;
-    end;
+    end
+  else if (Kind = tkFloat) and (TypeData^.FloatType = ftComp) then
+    Result := QWord(FData.FAsComp)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
 function TValue.AsInterface: IInterface;
@@ -2293,6 +2332,22 @@ begin
   end;
 end;
 
+procedure TValue.ExtractRawData(ABuffer: Pointer);
+begin
+  if Assigned(FData.FValueData) then
+    FData.FValueData.ExtractRawData(ABuffer)
+  else if Assigned(FData.FTypeInfo) then
+    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
+end;
+
+procedure TValue.ExtractRawDataNoCopy(ABuffer: Pointer);
+begin
+  if Assigned(FData.FValueData) then
+    FData.FValueData.ExtractRawDataNoCopy(ABuffer)
+  else if Assigned(FData.FTypeInfo) then
+    Move((@FData.FAsPointer)^, ABuffer^, DataSize);
+end;
+
 class operator TValue.:=(const AValue: String): TValue;
 begin
   Make(@AValue, System.TypeInfo(AValue), Result);
@@ -2389,6 +2444,116 @@ begin
   Result := FString;
 end;
 
+{ TMethodImplementation }
+
+function TMethodImplementation.GetCodeAddress: CodePointer;
+begin
+  Result := fLowLevelCallback.CodeAddress;
+end;
+
+procedure TMethodImplementation.InitArgs;
+var
+  i, refargs: SizeInt;
+begin
+  i := 0;
+  refargs := 0;
+  SetLength(fRefArgs, Length(fArgs));
+  while i < Length(fArgs) do begin
+    if (fArgs[i].ParamFlags * [pfVar, pfOut] <> []) and not (pfHidden in fArgs[i].ParamFlags) then begin
+      fRefArgs[refargs] := fArgLen;
+      Inc(refargs);
+    end;
+
+    if pfArray in fArgs[i].ParamFlags then begin
+      Inc(i);
+      if (i = Length(fArgs)) or not (pfHigh in fArgs[i].ParamFlags) then
+        raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+      Inc(fArgLen);
+    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then
+      Inc(fArgLen)
+    else if (pfResult in fArgs[i].ParamFlags) then
+      fResult := fArgs[i].ParamType;
+
+    Inc(i);
+  end;
+
+  SetLength(fRefArgs, refargs);
+end;
+
+procedure TMethodImplementation.HandleCallback(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+var
+  i, argidx: SizeInt;
+  args: TValueArray;
+  res: TValue;
+begin
+  Assert(fArgLen = Length(aArgs), 'Length of arguments does not match');
+  SetLength(args, fArgLen);
+  argidx := 0;
+  i := 0;
+  while i < Length(fArgs) do begin
+    if pfArray in fArgs[i].ParamFlags then begin
+      Inc(i);
+      Assert((i < Length(fArgs)) and (pfHigh in fArgs[i].ParamFlags), 'Expected high parameter after open array parameter');
+      TValue.MakeOpenArray(aArgs[i - 1], SizeInt(aArgs[i]), fArgs[i].ParamType, args[argidx]);
+    end else if not (pfHidden in fArgs[i].ParamFlags) or (pfSelf in fArgs[i].ParamFlags) then begin
+      TValue.Make(aArgs[i], fArgs[i].ParamType, args[argidx]);
+    end;
+
+    Inc(i);
+    Inc(argidx);
+  end;
+
+  if Assigned(fCallbackMethod) then
+    fCallbackMethod(aContext, args, res)
+  else
+    fCallbackProc(aContext, args, res);
+
+  { copy back var/out parameters }
+  for i := 0 to High(fRefArgs) do begin
+    args[fRefArgs[i]].ExtractRawData(aArgs[fRefArgs[i]]);
+  end;
+
+  if Assigned(fResult) then
+    res.ExtractRawData(aResult);
+end;
+
+constructor TMethodImplementation.Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackMethod);
+begin
+  fCC := aCC;
+  fArgs := aArgs;
+  fResult := aResult;
+  fFlags := aFlags;
+  fCallbackMethod := aCallback;
+  InitArgs;
+  fLowLevelCallback := CreateCallbackMethod(@HandleCallback, fCC, aArgs, aResult, aFlags, aUserData);
+  if not Assigned(fLowLevelCallback) then
+    raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+end;
+
+constructor TMethodImplementation.Create(aCC: TCallConv; aArgs: specialize TArray<TFunctionCallParameterInfo>; aResult: PTypeInfo; aFlags: TFunctionCallFlags; aUserData: Pointer; aCallback: TMethodImplementationCallbackProc);
+begin
+  fCC := aCC;
+  fArgs := aArgs;
+  fResult := aResult;
+  fFlags := aFlags;
+  fCallbackProc := aCallback;
+  InitArgs;
+  fLowLevelCallback := CreateCallbackMethod(@HandleCallback, fCC, aArgs, aResult, aFlags, aUserData);
+  if not Assigned(fLowLevelCallback) then
+    raise EInsufficientRtti.Create(SErrMethodImplCreateFailed);
+end;
+
+constructor TMethodImplementation.Create;
+begin
+  raise EInvalidOpException.Create(SErrMethodImplCreateNoArg);
+end;
+
+destructor TMethodImplementation.Destroy;
+begin
+  fLowLevelCallback.Free;
+  inherited Destroy;
+end;
+
 { TRttiMethod }
 
 function TRttiMethod.GetHasExtendedInfo: Boolean;
@@ -2507,6 +2672,70 @@ begin
   Result := GetParameters(False);
 end;
 
+function TRttiInvokableType.CreateImplementation(aCallback: TCallbackMethod): TMethodImplementation;
+var
+  params: specialize TArray<TRttiParameter>;
+  args: specialize TArray<TFunctionCallParameterInfo>;
+  res: PTypeInfo;
+  restype: TRttiType;
+  resinparam: Boolean;
+  i: SizeInt;
+begin
+  if not Assigned(aCallback) then
+    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
+
+  resinparam := False;
+  params := GetParameters(True);
+  SetLength(args, Length(params));
+  for i := 0 to High(params) do begin
+    args[i].ParamType := params[i].ParamType.FTypeInfo;
+    args[i].ParamFlags := params[i].Flags;
+    args[i].ParaLocs := Nil;
+    if pfResult in params[i].Flags then
+      resinparam := True;
+  end;
+
+  restype := GetReturnType;
+  if Assigned(restype) and not resinparam then
+    res := restype.FTypeInfo
+  else
+    res := Nil;
+
+  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, Self, TMethodImplementationCallbackMethod(aCallback));
+end;
+
+function TRttiInvokableType.CreateImplementation(aCallback: TCallbackProc): TMethodImplementation;
+var
+  params: specialize TArray<TRttiParameter>;
+  args: specialize TArray<TFunctionCallParameterInfo>;
+  res: PTypeInfo;
+  restype: TRttiType;
+  resinparam: Boolean;
+  i: SizeInt;
+begin
+  if not Assigned(aCallback) then
+    raise EArgumentNilException.Create(SErrMethodImplNoCallback);
+
+  resinparam := False;
+  params := GetParameters(True);
+  SetLength(args, Length(params));
+  for i := 0 to High(params) do begin
+    args[i].ParamType := params[i].ParamType.FTypeInfo;
+    args[i].ParamFlags := params[i].Flags;
+    args[i].ParaLocs := Nil;
+    if pfResult in params[i].Flags then
+      resinparam := True;
+  end;
+
+  restype := GetReturnType;
+  if Assigned(restype) and not resinparam then
+    res := restype.FTypeInfo
+  else
+    res := Nil;
+
+  Result := TMethodImplementation.Create(GetCallingConvention, args, res, GetFlags, Self, TMethodImplementationCallbackProc(aCallback));
+end;
+
 { TRttiMethodType }
 
 function TRttiMethodType.GetParameters(aWithHidden: Boolean): specialize TArray<TRttiParameter>;
@@ -2621,6 +2850,11 @@ begin
     Result := Nil;
 end;
 
+function TRttiMethodType.GetFlags: TFunctionCallFlags;
+begin
+  Result := [];
+end;
+
 function TRttiMethodType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
 var
   method: PMethod;
@@ -2709,6 +2943,11 @@ begin
   end;
 end;
 
+function TRttiProcedureType.GetFlags: TFunctionCallFlags;
+begin
+  Result := [fcfStatic];
+end;
+
 function TRttiProcedureType.Invoke(const aCallable: TValue; const aArgs: array of TValue): TValue;
 begin
   if aCallable.Kind <> tkProcVar then

packages/rtl-objpas/src/x86_64/invoke.inc

@@ -28,15 +28,16 @@ asm
 .seh_savereg %rsi, 16
   movq %rdi, 24(%rsp)
 .seh_savereg %rdi, 24
+  movq %r8, 32(%rsp)
+.seh_savereg %r8, 32
 
   movq %rsp, %rbp
 .seh_setframe %rbp, 0
 .seh_endprologue
 
   { align stack size to 16 Byte }
-  add $15, aArgsStackSize
-  and $-16, aArgsStackSize
   sub aArgsStackSize, %rsp
+  and $-16, %rsp
 
   movq aArgsStackSize, %rax
 
@@ -71,6 +72,10 @@ asm
   { restore non-volatile registers }
   movq %rbp, %rsp
 
+  { we abuse the register area pointer for an eventual SSE2 result }
+  movq 32(%rsp), %rdi
+  movq %xmm0, (%rdi)
+
   movq 24(%rsp), %rdi
   movq 16(%rsp), %rsi
   movq 8(%rsp), %rbp
@@ -81,6 +86,42 @@ resourcestring
   SErrFailedToConvertArg = 'Failed to convert argument %d of type %s';
   SErrFailedToConvertRes = 'Failed to convert result of type %s';
 
+function ReturnResultInParam(aType: PTypeInfo): Boolean;
+var
+  td: PTypeData;
+begin
+  Result := False;
+  if Assigned(aType) then begin
+    case aType^.Kind of
+      tkSString,
+      tkAString,
+      tkUString,
+      tkWString,
+      tkInterface,
+      tkDynArray:
+        Result := True;
+      tkArray: begin
+        td := GetTypeData(aType);
+        Result := not (td^.ArrayData.Size in [1, 2, 4, 8]);
+      end;
+      tkRecord: begin
+        td := GetTypeData(aType);
+        Result := not (td^.RecSize in [1, 2, 4, 8]);
+      end;
+      tkSet: begin
+        td := GetTypeData(aType);
+        case td^.OrdType of
+          otUByte:
+            Result := not (td^.SetSize in [1, 2, 4, 8]);
+          otUWord,
+          otULong:
+            Result := False;
+        end;
+      end;
+    end;
+  end;
+end;
+
 procedure SystemInvoke(aCodeAddress: CodePointer; const aArgs: TFunctionCallParameterArray; aCallConv: TCallConv;
             aResultType: PTypeInfo; aResultValue: Pointer; aFlags: TFunctionCallFlags);
 type
@@ -102,18 +143,7 @@ begin
   if Assigned(aResultType) and not Assigned(aResultValue) then
     raise EInvocationError.Create(SErrInvokeResultTypeNoValue);
 {$ifdef windows}
-  retinparam := False;
+  retinparam := ReturnResultInParam(aResultType);
-  if Assigned(aResultType) then begin
-    case aResultType^.Kind of
-      tkSString,
-      tkAString,
-      tkUString,
-      tkWString,
-      tkInterface,
-      tkDynArray:
-        retinparam := True;
-    end;
-  end;
 
   stackidx := 0;
   regidx := 0;
@@ -249,6 +279,11 @@ begin
 
   if Assigned(aResultType) and not retinparam then begin
     PPtrUInt(aResultValue)^ := val;
+    if aResultType^.Kind = tkFloat then begin
+      td := GetTypeData(aResultType);
+      if td^.FloatType in [ftSingle, ftDouble] then
+        PPtrUInt(aResultValue)^ := regs[0];
+    end;
   end;
 {$else}
   raise EInvocationError.Create(SErrPlatformNotSupported);

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -21,6 +21,9 @@ uses
   consoletestrunner,
 {$ifdef testinvoke}
   tests.rtti.invoke,
+{$endif}
+{$ifdef testimpl}
+  tests.rtti.impl,
 {$endif}
   tests.rtti;
 

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

@@ -0,0 +1,582 @@
+unit Tests.Rtti.Impl;
+
+{$ifdef fpc}
+{$mode objfpc}{$H+}
+{$endif}
+
+{.$define debug}
+
+interface
+
+uses
+{$IFDEF FPC}
+  fpcunit,testregistry, testutils,
+{$ELSE FPC}
+  TestFramework,
+{$ENDIF FPC}
+  sysutils, typinfo, Rtti,
+  Tests.Rtti.Util;
+
+{ Note: Delphi does not provide a CreateImplementation for TRttiInvokableType
+        and its descendants, so these tests are disabled for Delphi }
+
+type
+  TTestImpl = class(TTestCase)
+  private
+    InputArgs: array of TValue;
+    OutputArgs: array of TValue;
+    ResultValue: TValue;
+    InOutMapping: array of SizeInt;
+
+{$ifdef fpc}
+    procedure OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out aResult: TValue);
+    procedure DoMethodImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+    procedure DoProcImpl(aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+{$ifndef InLazIDE}
+    {$ifdef fpc}generic{$endif} procedure GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+    {$ifdef fpc}generic{$endif} procedure GenDoProcImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+{$endif}
+{$endif}
+{$ifdef fpc}
+    procedure Status(const aMsg: String); inline;
+    procedure Status(const aMsg: String; const aArgs: array of const); inline;
+{$endif}
+  published
+{$ifdef fpc}
+    procedure TestMethodVars;
+    procedure TestProcVars;
+{$endif}
+  end;
+
+implementation
+
+type
+  TTestMethod1 = procedure of object;
+  TTestMethod2 = function(aArg1: SizeInt): SizeInt of object;
+  TTestMethod3 = procedure(aArg1: AnsiString) of object;
+  TTestMethod4 = procedure(aArg1: ShortString) of object;
+  TTestMethod5 = function: AnsiString of object;
+  TTestMethod6 = function: ShortString of object;
+  TTestMethod7 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt) of object;
+  TTestMethod8 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString) of object;
+  TTestMethod9 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString) of object;
+  TTestMethod10 = procedure(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single) of object;
+  TTestMethod11 = procedure(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double) of object;
+  TTestMethod12 = procedure(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended) of object;
+  TTestMethod13 = procedure(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp) of object;
+  TTestMethod14 = procedure(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency) of object;
+  TTestMethod15 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object;
+  TTestMethod16 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single of object;
+  TTestMethod17 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double of object;
+  TTestMethod18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended of object;
+  TTestMethod19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp of object;
+  TTestMethod20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency of object;
+
+  TTestProc1 = procedure;
+  TTestProc2 = function(aArg1: SizeInt): SizeInt;
+  TTestProc3 = procedure(aArg1: AnsiString);
+  TTestProc4 = procedure(aArg1: ShortString);
+  TTestProc5 = function: AnsiString;
+  TTestProc6 = function: ShortString;
+  TTestProc7 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt);
+  TTestProc8 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString);
+  TTestProc9 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString);
+  TTestProc10 = procedure(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single);
+  TTestProc11 = procedure(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double);
+  TTestProc12 = procedure(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended);
+  TTestProc13 = procedure(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp);
+  TTestProc14 = procedure(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency);
+  TTestProc15 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
+  TTestProc16 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+  TTestProc17 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+  TTestProc18 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+  TTestProc19 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+  TTestProc20 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+
+const
+  SingleArg1: Single = 1.23;
+  SingleArg2In: Single = 3.21;
+  SingleArg2Out: Single = 2.34;
+  SingleArg3Out: Single = 9.87;
+  SingleArg4: Single = 7.89;
+  SingleRes: Single = 4.32;
+  SingleAddArg1 = Single(1.23);
+  SingleAddArg2 = Single(2.34);
+  SingleAddArg3 = Single(3.45);
+  SingleAddArg4 = Single(4.56);
+  SingleAddArg5 = Single(5.67);
+  SingleAddArg6 = Single(9.87);
+  SingleAddArg7 = Single(8.76);
+  SingleAddArg8 = Single(7.65);
+  SingleAddArg9 = Single(6.54);
+  SingleAddArg10 = Single(5.43);
+  SingleAddRes = SingleAddArg1 + SingleAddArg2 + SingleAddArg3 + SingleAddArg4 + SingleAddArg5 +
+                 SingleAddArg6 + SingleAddArg7 + SingleAddArg8 + SingleAddArg9 + SingleAddArg10;
+
+  DoubleArg1: Double = 1.23;
+  DoubleArg2In: Double = 3.21;
+  DoubleArg2Out: Double = 2.34;
+  DoubleArg3Out: Double = 9.87;
+  DoubleArg4: Double = 7.89;
+  DoubleRes: Double = 4.32;
+  DoubleAddArg1 = Double(1.23);
+  DoubleAddArg2 = Double(2.34);
+  DoubleAddArg3 = Double(3.45);
+  DoubleAddArg4 = Double(4.56);
+  DoubleAddArg5 = Double(5.67);
+  DoubleAddArg6 = Double(9.87);
+  DoubleAddArg7 = Double(8.76);
+  DoubleAddArg8 = Double(7.65);
+  DoubleAddArg9 = Double(6.54);
+  DoubleAddArg10 = Double(5.43);
+  DoubleAddRes = DoubleAddArg1 + DoubleAddArg2 + DoubleAddArg3 + DoubleAddArg4 + DoubleAddArg5 +
+                 DoubleAddArg6 + DoubleAddArg7 + DoubleAddArg8 + DoubleAddArg9 + DoubleAddArg10;
+
+  ExtendedArg1: Extended = 1.23;
+  ExtendedArg2In: Extended = 3.21;
+  ExtendedArg2Out: Extended = 2.34;
+  ExtendedArg3Out: Extended = 9.87;
+  ExtendedArg4: Extended = 7.89;
+  ExtendedRes: Extended = 4.32;
+  ExtendedAddArg1 = Extended(1.23);
+  ExtendedAddArg2 = Extended(2.34);
+  ExtendedAddArg3 = Extended(3.45);
+  ExtendedAddArg4 = Extended(4.56);
+  ExtendedAddArg5 = Extended(5.67);
+  ExtendedAddArg6 = Extended(9.87);
+  ExtendedAddArg7 = Extended(8.76);
+  ExtendedAddArg8 = Extended(7.65);
+  ExtendedAddArg9 = Extended(6.54);
+  ExtendedAddArg10 = Extended(5.43);
+  ExtendedAddRes = ExtendedAddArg1 + ExtendedAddArg2 + ExtendedAddArg3 + ExtendedAddArg4 + ExtendedAddArg5 +
+                 ExtendedAddArg6 + ExtendedAddArg7 + ExtendedAddArg8 + ExtendedAddArg9 + ExtendedAddArg10;
+
+  CurrencyArg1: Currency = 1.23;
+  CurrencyArg2In: Currency = 3.21;
+  CurrencyArg2Out: Currency = 2.34;
+  CurrencyArg3Out: Currency = 9.87;
+  CurrencyArg4: Currency = 7.89;
+  CurrencyRes: Currency = 4.32;
+  CurrencyAddArg1 = Currency(1.23);
+  CurrencyAddArg2 = Currency(2.34);
+  CurrencyAddArg3 = Currency(3.45);
+  CurrencyAddArg4 = Currency(4.56);
+  CurrencyAddArg5 = Currency(5.67);
+  CurrencyAddArg6 = Currency(9.87);
+  CurrencyAddArg7 = Currency(8.76);
+  CurrencyAddArg8 = Currency(7.65);
+  CurrencyAddArg9 = Currency(6.54);
+  CurrencyAddArg10 = Currency(5.43);
+  CurrencyAddRes = CurrencyAddArg1 + CurrencyAddArg2 + CurrencyAddArg3 + CurrencyAddArg4 + CurrencyAddArg5 +
+                 CurrencyAddArg6 + CurrencyAddArg7 + CurrencyAddArg8 + CurrencyAddArg9 + CurrencyAddArg10;
+
+  CompArg1: Comp = 123;
+  CompArg2In: Comp = 321;
+  CompArg2Out: Comp = 234;
+  CompArg3Out: Comp = 987;
+  CompArg4: Comp = 789;
+  CompRes: Comp = 432;
+  CompAddArg1 = Comp(123);
+  CompAddArg2 = Comp(234);
+  CompAddArg3 = Comp(345);
+  CompAddArg4 = Comp(456);
+  CompAddArg5 = Comp(567);
+  CompAddArg6 = Comp(987);
+  CompAddArg7 = Comp(876);
+  CompAddArg8 = Comp(765);
+  CompAddArg9 = Comp(654);
+  CompAddArg10 = Comp(543);
+  CompAddRes = CompAddArg1 + CompAddArg2 + CompAddArg3 + CompAddArg4 + CompAddArg5 +
+                 CompAddArg6 + CompAddArg7 + CompAddArg8 + CompAddArg9 + CompAddArg10;
+
+{ TTestImpl }
+
+{$ifdef fpc}
+procedure TTestImpl.Status(const aMsg: String);
+begin
+{$ifdef debug}
+  Writeln(aMsg);
+{$endif}
+end;
+
+procedure TTestImpl.Status(const aMsg: String; const aArgs: array of const);
+begin
+{$ifdef debug}
+  Writeln(Format(aMsg, aArgs));
+{$endif}
+end;
+{$endif}
+
+{$ifdef fpc}
+procedure TTestImpl.OnHandleInvokable(aInvokable: TRttiInvokableType; const aArgs: TValueArray; out
+  aResult: TValue);
+var
+  selfofs, i: SizeInt;
+begin
+  CheckTrue((aInvokable is TRttiMethodType) or (aInvokable is TRttiProcedureType), 'Invokable is not a method or procedure variable: ' + aInvokable.ClassName);
+
+  selfofs := 0;
+  if aInvokable is TRttiMethodType then
+    selfofs := 1;
+
+  Status('In Callback');
+  Status('Self: ' + HexStr(Self));
+  if Assigned(aInvokable.ReturnType) then
+    aResult := CopyValue(ResultValue);
+  Status('Setting input args');
+  SetLength(InputArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do begin
+    Status('Arg %d: %p %p', [i, aArgs[i].GetReferenceToRawData, PPointer(aArgs[i].GetReferenceToRawData)^]);
+    InputArgs[i] := CopyValue(aArgs[i]);
+  end;
+  Status('Setting output args');
+  { Note: account for Self }
+  for i := 0 to High(InOutMapping) do begin
+    Status('OutputArg %d -> Arg %d', [i, InOutMapping[i] + selfofs]);
+    { check input arg type? }
+    Move(OutputArgs[i].GetReferenceToRawData^, aArgs[InOutMapping[i] + selfofs].GetReferenceToRawData^, OutputArgs[i].DataSize);
+  end;
+  Status('Callback done');
+end;
+
+procedure TTestImpl.DoMethodImpl(aTypeInfo: PTypeInfo; aInputArgs,
+  aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+var
+  context: TRttiContext;
+  t: TRttiType;
+  callable, res: TValue;
+  method: TRttiMethodType;
+  i: SizeInt;
+  input: array of TValue;
+  impl: TMethodImplementation;
+  mrec: TMethod;
+  name: String;
+begin
+  name := aTypeInfo^.Name;
+
+  impl := Nil;
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiMethodType, 'Not a method variable: ' + name);
+    method := t as TRttiMethodType;
+
+    Status('Executing method %s', [name]);
+
+    CheckEquals(Length(aOutputArgs), Length(aInOutMapping), 'Invalid in/out mapping');
+    Check(Length(aOutputArgs) <= Length(aInputArgs), 'Output args not part of input args');
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs) + 1);
+    input[0] := GetPointerValue(Self);
+    for i := 0 to High(aInputArgs) do
+      input[i + 1] := CopyValue(aInputArgs[i]);
+
+    impl := method.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    CheckNotNull(impl, 'Method implementation is Nil');
+
+    mrec.Data := Self;
+    mrec.Code := impl.CodeAddress;
+    TValue.Make(@mrec, aTypeInfo, callable);
+
+    SetLength(InOutMapping, Length(aInOutMapping));
+    for i := 0 to High(InOutMapping) do
+      InOutMapping[i] := aInOutMapping[i];
+    SetLength(OutputArgs, Length(aOutputArgs));
+    for i := 0 to High(OutputArgs) do
+      OutputArgs[i] := CopyValue(aOutputArgs[i]);
+    ResultValue := aResult;
+
+    res := method.Invoke(callable, aInputArgs);
+    Status('After invoke');
+
+    Check(EqualValues(ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(input), Length(InputArgs), 'Count of input args differs for ' + name);
+    for i := 0 to High(input) do begin
+      Check(EqualValues(input[i], InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], aInputArgs[InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    impl.Free;
+    context.Free;
+  end;
+end;
+
+procedure TTestImpl.DoProcImpl(aTypeInfo: PTypeInfo; aInputArgs,
+  aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+var
+  context: TRttiContext;
+  t: TRttiType;
+  callable, res: TValue;
+  proc: TRttiProcedureType;
+  i: SizeInt;
+  input: array of TValue;
+  impl: TMethodImplementation;
+  name: String;
+  cp: CodePointer;
+begin
+  name := aTypeInfo^.Name;
+
+  impl := Nil;
+  context := TRttiContext.Create;
+  try
+    t := context.GetType(aTypeInfo);
+    Check(t is TRttiProcedureType, 'Not a procedure variable: ' + name);
+    proc := t as TRttiProcedureType;
+
+    Status('Executing procedure %s', [name]);
+
+    CheckEquals(Length(aOutputArgs), Length(aInOutMapping), 'Invalid in/out mapping');
+    Check(Length(aOutputArgs) <= Length(aInputArgs), 'Output args not part of input args');
+
+    { arguments might be modified by Invoke (Note: Copy() does not uniquify the
+      IValueData of managed types) }
+    SetLength(input, Length(aInputArgs));
+    for i := 0 to High(aInputArgs) do
+      input[i] := CopyValue(aInputArgs[i]);
+
+    impl := proc.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    CheckNotNull(impl, 'Method implementation is Nil');
+
+    cp := impl.CodeAddress;
+    TValue.Make(@cp, aTypeInfo, callable);
+
+    SetLength(InOutMapping, Length(aInOutMapping));
+    for i := 0 to High(InOutMapping) do
+      InOutMapping[i] := aInOutMapping[i];
+    SetLength(OutputArgs, Length(aOutputArgs));
+    for i := 0 to High(OutputArgs) do
+      OutputArgs[i] := CopyValue(aOutputArgs[i]);
+    ResultValue := aResult;
+
+    res := proc.Invoke(callable, aInputArgs);
+    Status('After invoke');
+
+    Check(EqualValues(ResultValue, res), 'Reported result value differs from returned for ' + name);
+    Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
+    CheckEquals(Length(input), Length(InputArgs), 'Count of input args differs for ' + name);
+    for i := 0 to High(input) do begin
+      Check(EqualValues(input[i], InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
+    end;
+    for i := 0 to High(aOutputArgs) do begin
+      Check(EqualValues(aOutputArgs[i], aInputArgs[InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
+    end;
+  finally
+    impl.Free;
+    context.Free;
+  end;
+end;
+{$endif}
+
+{$ifndef InLazIDE}
+{$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoMethodImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+begin
+  DoMethodImpl(TypeInfo(T), aInputArgs, aOutputArgs, aInOutMapping, aResult);
+end;
+
+{$ifdef fpc}generic{$endif} procedure TTestImpl.GenDoProcImpl<T>(aInputArgs, aOutputArgs: TValueArray; aInOutMapping: array of SizeInt; aResult: TValue);
+begin
+  DoProcImpl(TypeInfo(T), aInputArgs, aOutputArgs, aInOutMapping, aResult);
+end;
+{$endif}
+
+{$ifdef fpc}
+procedure TTestImpl.TestMethodVars;
+begin
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod1>([], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod2>([GetIntValue(42)], [], [], GetIntValue(21));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod3>([GetAnsiString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod4>([GetShortString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod5>([], [], [], GetAnsiString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod6>([], [], [], GetShortString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod7>([
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod8>([
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod9>([
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod10>([
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+  ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod11>([
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+  ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod12>([
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+  ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod13>([
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+  ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod14>([
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+  ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod15>([
+    GetIntValue(1), GetIntValue(2), GetIntValue(3), GetIntValue(4), GetIntValue(5),
+    GetIntValue(6), GetIntValue(7), GetIntValue(8), GetIntValue(9), GetIntValue(10)
+  ], [], [], GetIntValue(11));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod16>([
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+  ], [], [], GetSingleValue(SingleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod17>([
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+  ], [], [], GetDoubleValue(DoubleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod18>([
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+  ], [], [], GetExtendedValue(ExtendedAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod19>([
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+  ], [], [], GetCompValue(CompAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoMethodImpl<TTestMethod20>([
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+  ], [], [], GetCurrencyValue(CurrencyAddRes));
+end;
+
+procedure TTestImpl.TestProcVars;
+begin
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc1>([], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc2>([GetIntValue(42)], [], [], GetIntValue(21));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc3>([GetAnsiString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc4>([GetShortString('Hello World')], [], [], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc5>([], [], [], GetAnsiString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc6>([], [], [], GetShortString('Hello World'));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc7>([
+    GetIntValue(1234), GetIntValue(4321), GetIntValue(0), GetIntValue(9876)
+  ], [
+    GetIntValue(5678), GetIntValue(6789)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc8>([
+    GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
+  ], [
+    GetAnsiString('Gamma'), GetAnsiString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc9>([
+    GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
+  ], [
+    GetShortString('Gamma'), GetShortString('Epsilon')
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc10>([
+    GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
+  ], [
+    GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc11>([
+    GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
+  ], [
+    GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc12>([
+    GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
+  ], [
+    GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc13>([
+    GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
+  ], [
+    GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc14>([
+    GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
+  ], [
+    GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
+  ], [1, 2], TValue.Empty);
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc15>([
+    GetIntValue(1), GetIntValue(2), GetIntValue(3), GetIntValue(4), GetIntValue(5),
+    GetIntValue(6), GetIntValue(7), GetIntValue(8), GetIntValue(9), GetIntValue(10)
+  ], [], [], GetIntValue(11));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc16>([
+    GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
+    GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
+  ], [], [], GetSingleValue(SingleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc17>([
+    GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
+    GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
+  ], [], [], GetDoubleValue(DoubleAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc18>([
+    GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
+    GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
+  ], [], [], GetExtendedValue(ExtendedAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc19>([
+    GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
+    GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
+  ], [], [], GetCompValue(CompAddRes));
+
+  {$ifdef fpc}specialize{$endif}GenDoProcImpl<TTestProc20>([
+    GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
+    GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
+  ], [], [], GetCurrencyValue(CurrencyAddRes));
+end;
+{$endif}
+
+initialization
+{$ifdef fpc}
+  RegisterTest(TTestImpl);
+{$else fpc}
+  RegisterTest(TTestImpl.Suite);
+{$endif fpc}
+end.
+

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

@@ -55,6 +55,11 @@ type
 {$ifdef fpc}
     procedure TestMakeArrayOpen;
 {$endif}
+    procedure TestMakeSingle;
+    procedure TestMakeDouble;
+    procedure TestMakeExtended;
+    procedure TestMakeCurrency;
+    procedure TestMakeComp;
 
     procedure TestDataSize;
     procedure TestDataSizeEmpty;
@@ -482,8 +487,184 @@ begin
   CheckEquals(arr[0], 84);
   CheckEquals(arr[1], 128);
 end;
+
 {$endif}
 
+procedure TTestCase1.TestMakeSingle;
+var
+  fs: Single;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fs := 3.14;
+
+  TValue.Make(@fs, TypeInfo(fs), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fs);
+  Check(v.GetReferenceToRawData <> @fs);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeDouble;
+var
+  fd: Double;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fd := 3.14;
+
+  TValue.Make(@fd, TypeInfo(fd), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fd);
+  Check(v.GetReferenceToRawData <> @fd);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeExtended;
+var
+  fe: Extended;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fe := 3.14;
+
+  TValue.Make(@fe, TypeInfo(fe), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fe);
+  Check(v.GetReferenceToRawData <> @fe);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeCurrency;
+var
+  fcu: Currency;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fcu := 3.14;
+
+  TValue.Make(@fcu, TypeInfo(fcu), v);
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fcu);
+  Check(v.AsCurrency=fcu);
+  Check(v.GetReferenceToRawData <> @fcu);
+
+  try
+    hadexcept := False;
+    v.AsInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No signed type conversion exception');
+
+  try
+    hadexcept := False;
+    v.AsUInt64;
+  except
+    hadexcept := True;
+  end;
+
+  CheckTrue(hadexcept, 'No unsigned type conversion exception');
+end;
+
+procedure TTestCase1.TestMakeComp;
+var
+  fco: Comp;
+  v: TValue;
+  hadexcept: Boolean;
+begin
+  fco := 314;
+
+  TValue.Make(@fco, TypeInfo(fco), v);
+
+  if v.Kind <> tkFloat then
+    Exit;
+
+  CheckEquals(v.IsClass, False);
+  CheckEquals(v.IsObject, False);
+  CheckEquals(v.IsOrdinal, False);
+  Check(v.AsExtended=fco);
+  Check(v.GetReferenceToRawData <> @fco);
+
+  try
+    hadexcept := False;
+    CheckEquals(v.AsInt64, 314);
+  except
+    hadexcept := True;
+  end;
+
+  CheckFalse(hadexcept, 'Had signed type conversion exception');
+
+  try
+    hadexcept := False;
+    CheckEquals(v.AsUInt64, 314);
+  except
+    hadexcept := True;
+  end;
+
+  CheckFalse(hadexcept, 'Had unsigned type conversion exception');
+end;
+
 procedure TTestCase1.TestGetIsReadable;
 var
   c: TRttiContext;

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

@@ -0,0 +1,244 @@
+unit Tests.Rtti.Util;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Rtti;
+
+{$ifndef fpc}
+type
+  CodePointer = Pointer;
+
+  TValueHelper = record helper for TValue
+    function AsUnicodeString: UnicodeString;
+    function AsAnsiString: AnsiString;
+  end;
+{$endif}
+
+function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
+function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
+
+function TypeKindToStr(aTypeKind: TTypeKind): String; inline;
+
+function GetInstValue(aValue: TObject): TValue;
+function GetPointerValue(aValue: Pointer): TValue;
+function GetIntValue(aValue: SizeInt): TValue;
+function GetAnsiString(const aValue: AnsiString): TValue;
+function GetShortString(const aValue: ShortString): TValue;
+function GetSingleValue(aValue: Single): TValue;
+function GetDoubleValue(aValue: Double): TValue;
+function GetExtendedValue(aValue: Extended): TValue;
+function GetCompValue(aValue: Comp): TValue;
+function GetCurrencyValue(aValue: Currency): TValue;
+function GetArray(const aArg: array of SizeInt): TValue;
+
+implementation
+
+uses
+  TypInfo, SysUtils;
+
+{$ifndef fpc}
+function TValueHelper.AsUnicodeString: UnicodeString;
+begin
+  Result := UnicodeString(AsString);
+end;
+
+function TValueHelper.AsAnsiString: AnsiString;
+begin
+  Result := AnsiString(AsString);
+end;
+{$endif}
+
+function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
+var
+  arrptr: Pointer;
+  len, i: SizeInt;
+begin
+  if aValue.Kind = tkDynArray then begin
+    { we need to decouple the source reference, so we're going to be a bit
+      cheeky here }
+    len := aValue.GetArrayLength;
+    arrptr := Nil;
+    DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
+    TValue.Make(@arrptr, aValue.TypeInfo, Result);
+    for i := 0 to len - 1 do
+      Result.SetArrayElement(i, aValue.GetArrayElement(i));
+  end else
+    TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
+end;
+
+function EqualValues({$ifdef fpc}constref{$else}const [ref]{$endif} aValue1, aValue2: TValue): Boolean;
+var
+  td1, td2: PTypeData;
+  i: SizeInt;
+begin
+{$ifdef debug}
+  Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
+  Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
+  Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
+{$endif}
+  if aValue1.IsEmpty and aValue2.IsEmpty then
+    Result := True
+  else if aValue1.IsEmpty and not aValue2.IsEmpty then
+    Result := False
+  else if not aValue1.IsEmpty and aValue2.IsEmpty then
+    Result := False
+  else if aValue1.IsArray and aValue2.IsArray then begin
+    if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
+      Result := True;
+      for i := 0 to aValue1.GetArrayLength - 1 do
+        if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
+          Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
+          Result := False;
+          Break;
+        end;
+    end else
+      Result := False;
+  end else if aValue1.Kind = aValue2.Kind then begin
+    td1 := aValue1.TypeData;
+    td2 := aValue2.TypeData;
+    case aValue1.Kind of
+      tkBool:
+        Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
+      tkSet:
+        if td1^.SetSize = td2^.SetSize then
+          if td1^.SetSize < SizeOf(SizeInt) then
+            Result := aValue1.AsOrdinal = aValue2.AsOrdinal
+          else
+            Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
+        else
+          Result := False;
+      tkEnumeration,
+      tkChar,
+      tkWChar,
+      tkUChar,
+      tkInt64,
+      tkInteger:
+        Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
+      tkQWord:
+        Result := aValue1.AsUInt64 = aValue2.AsUInt64;
+      tkFloat:
+        if td1^.FloatType <> td2^.FloatType then
+          Result := False
+        else begin
+          case td1^.FloatType of
+            ftSingle,
+            ftDouble,
+            ftExtended:
+              Result := aValue1.AsExtended = aValue2.AsExtended;
+            ftComp:
+              Result := aValue1.AsInt64 = aValue2.AsInt64;
+            ftCurr:
+              Result := aValue1.AsCurrency = aValue2.AsCurrency;
+          end;
+        end;
+      tkSString,
+      tkUString,
+      tkAString,
+      tkWString:
+        Result := aValue1.AsString = aValue2.AsString;
+      tkDynArray,
+      tkArray:
+        if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
+          Result := True;
+          for i := 0 to aValue1.GetArrayLength - 1 do
+            if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
+              Result := False;
+              Break;
+            end;
+        end else
+          Result := False;
+      tkClass,
+      tkClassRef,
+      tkInterface,
+      tkInterfaceRaw,
+      tkPointer:
+        Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
+      tkProcVar:
+        Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
+      tkRecord,
+      tkObject,
+      tkMethod,
+      tkVariant: begin
+        if aValue1.DataSize = aValue2.DataSize then
+          Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
+        else
+          Result := False;
+      end
+      else
+        Result := False;
+    end;
+  end else
+    Result := False;
+end;
+
+function TypeKindToStr(aTypeKind: TTypeKind): String;
+begin
+{$ifdef fpc}
+  Str(aTypeKind, Result);
+{$else}
+  Result := GetEnumName(TypeInfo(TTypeKind), Ord(aTypeKind));
+{$endif}
+end;
+
+function GetInstValue(aValue: TObject): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<TObject>(aValue);
+end;
+
+function GetPointerValue(aValue: Pointer): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Pointer>(aValue);
+end;
+
+function GetIntValue(aValue: SizeInt): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
+end;
+
+function GetAnsiString(const aValue: AnsiString): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
+end;
+
+function GetShortString(const aValue: ShortString): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
+end;
+
+function GetSingleValue(aValue: Single): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Single>(aValue);
+end;
+
+function GetDoubleValue(aValue: Double): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Double>(aValue);
+end;
+
+function GetExtendedValue(aValue: Extended): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Extended>(aValue);
+end;
+
+function GetCompValue(aValue: Comp): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Comp>(aValue);
+end;
+
+function GetCurrencyValue(aValue: Currency): TValue;
+begin
+  Result := TValue.{$ifdef fpc}specialize{$endif}From<Currency>(aValue);
+end;
+
+{$ifdef fpc}
+function GetArray(const aArg: array of SizeInt): TValue;
+begin
+  Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
+end;
+{$endif}
+
+end.
+

tests/webtbs/tw34496.pp

@@ -0,0 +1,30 @@
+{ %TARGET = Win64 }
+
+program tw34496;
+
+{$MODE DELPHI}
+{$WARN 5079 OFF}
+
+uses
+  TypInfo,
+  Rtti;
+
+procedure Test1(const d1, d2: Double);
+begin
+  WriteLn(d1:0:2,' - ', d2:0:2);
+end;
+
+procedure Test2(const d1, d2: Extended);
+begin
+  WriteLn(d1:0:2,' - ', d2:0:2);
+end;
+
+var
+  a, b: Double;
+begin
+  a := 12.34;
+  b := 56.78;
+  Rtti.Invoke(@Test1, [a, b], ccReg, nil, True, False);
+  Rtti.Invoke(@Test2, [a, b], ccReg, nil, True, False);
+  //ReadLn;
+end.

tests/webtbs/tw34509.pp

@@ -0,0 +1,33 @@
+{ %TARGET = win64 }
+
+program tw34509;
+
+{$MODE DELPHI}
+
+uses
+  TypInfo,
+  RTTI;
+
+type
+  TRec = record
+    S: string;
+    I: Integer;
+  end;
+
+function Test(P: TRec): TRec;
+begin
+  Result := P;
+  WriteLn('P: ', P.S, ' - ', P.I);
+end;
+
+var
+  V: TValue;
+  R1, R2: TRec;
+begin
+  R1.S := 'abc';
+  R1.I := 123;
+  TValue.Make(@R1, TypeInfo(TRec), V);
+  R2 := TRec(Rtti.Invoke(@Test, [V], ccReg, TypeInfo(TRec), True, False).GetReferenceToRawData^);
+  WriteLn('R: ', R2.S, ' - ', R2.I);
+  //ReadLn;
+end.