mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 21:09:24 +02:00
# 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 -
This commit is contained in:
marco
parent
0f4e7b65b2
commit
a85fa3a3d8
4
.gitattributes
vendored
4
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -500,7 +500,6 @@ const
|
||||
Invoke: @FFIInvoke;
|
||||
CreateCallbackProc: Nil;
|
||||
CreateCallbackMethod: Nil;
|
||||
FreeCallback: Nil
|
||||
);
|
||||
|
||||
var
|
||||
|
||||
@ -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 = (
|
||||
fcfStatic
|
||||
);
|
||||
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;
|
||||
TFunctionCallProc = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
|
||||
TFunctionCallMethod = procedure(const aArgs: specialize TArray<Pointer>; aResult: Pointer; 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;
|
||||
CreateCallbackMethod: function(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
|
||||
FreeCallback: procedure(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
|
||||
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 TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
|
||||
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 CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of PTypeInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
|
||||
procedure FreeCallback(aCallback: TFunctionCallCallback; aCallConv: TCallConv);
|
||||
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 TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
|
||||
|
||||
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
|
||||
size := Length(PShortString(ABuffer)^) + 1
|
||||
else
|
||||
size := 256;
|
||||
result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, size, ATypeInfo, True);
|
||||
td := GetTypeData(ATypeInfo);
|
||||
result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, td^.MaxLength + 1, 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
|
||||
|
||||
@ -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;
|
||||
if Assigned(aResultType) then begin
|
||||
case aResultType^.Kind of
|
||||
tkSString,
|
||||
tkAString,
|
||||
tkUString,
|
||||
tkWString,
|
||||
tkInterface,
|
||||
tkDynArray:
|
||||
retinparam := True;
|
||||
end;
|
||||
end;
|
||||
retinparam := ReturnResultInParam(aResultType);
|
||||
|
||||
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);
|
||||
|
||||
@ -21,6 +21,9 @@ uses
|
||||
consoletestrunner,
|
||||
{$ifdef testinvoke}
|
||||
tests.rtti.invoke,
|
||||
{$endif}
|
||||
{$ifdef testimpl}
|
||||
tests.rtti.impl,
|
||||
{$endif}
|
||||
tests.rtti;
|
||||
|
||||
|
||||
582
packages/rtl-objpas/tests/tests.rtti.impl.pas
Normal file
582
packages/rtl-objpas/tests/tests.rtti.impl.pas
Normal file
@ -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.
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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;
|
||||
|
||||
244
packages/rtl-objpas/tests/tests.rtti.util.pas
Normal file
244
packages/rtl-objpas/tests/tests.rtti.util.pas
Normal file
@ -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.
|
||||
|
||||
30
tests/webtbs/tw34496.pp
Normal file
30
tests/webtbs/tw34496.pp
Normal file
@ -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.
|
||||
33
tests/webtbs/tw34509.pp
Normal file
33
tests/webtbs/tw34509.pp
Normal file
@ -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.
|
||||
Loading…
Reference in New Issue
Block a user