paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 11:39:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* only check result if the call itself succeeded (e.g. didn't fail due to the invoke manager not supporting the calling convention)

Browse Source 
git-svn-id: trunk@37700 -
This commit is contained in:
svenbarth 2017-12-08 14:56:48 +00:00
parent eaf878e106
commit 0954572af9
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
packages/rtl-objpas/tests/tests.rtti.invoke.pas
View File

@ -25,7 +25,7 @@ type
);
TInvokeFlags = set of TInvokeFlag;
private
function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags): TValue;
function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
procedure DoStaticInvokeTestUnicodeStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString);
@ -66,14 +66,16 @@ end;
{$endif}
function TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags): TValue;
aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
begin
try
Result := Rtti.Invoke(aCodeAddress, aArgs, aCallConv, aResultType, ifStatic in aFlags, ifConstructor in aFlags);
aValid := True;
except
on e: ENotImplemented do
on e: ENotImplemented do begin
Status('Ignoring unimplemented functionality of test');
else
aValid := False;
end else
raise;
end;
end;
@ -81,9 +83,10 @@ end;
procedure TTestInvoke.DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
var
resval: TValue;
valid: Boolean;
begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic]);
if Assigned(aReturnType) and (resval.AsOrdinal <> aResult) then begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
if valid and Assigned(aReturnType) and (resval.AsOrdinal <> aResult) then begin
Fail('Result of test "%s" is unexpected; expected: %s, got: %s', [aTestName, IntToStr(aResult), IntToStr(resval.AsOrdinal)]);
end;
end;
@ -93,9 +96,10 @@ procedure TTestInvoke.DoStaticInvokeTestAnsiStringCompare(
aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
var
resval: TValue;
valid: Boolean;
begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic]);
if Assigned(aReturnType) and (resval.AsAnsiString <> aResult) then begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
if valid and Assigned(aReturnType) and (resval.AsAnsiString <> aResult) then begin
Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
end;
end;
@ -106,9 +110,10 @@ procedure TTestInvoke.DoStaticInvokeTestUnicodeStringCompare(
);
var
resval: TValue;
valid: Boolean;
begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic]);
if Assigned(aReturnType) and (resval.AsUnicodeString <> aResult) then begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
if valid and Assigned(aReturnType) and (resval.AsUnicodeString <> aResult) then begin
Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
end;
end;
@ -463,9 +468,10 @@ procedure TTestInvoke.TestTObject;
var
resval: TValue;
rescls: TTestClass;
valid: Boolean;
begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic]);
if Assigned(aReturnType) then begin
resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
if valid and Assigned(aReturnType) then begin
rescls := TTestClass(PPointer(resval.GetReferenceToRawData)^);
if (rescls.fString <> aResult.fString) or (rescls.fValue <> aResult.fValue) then
Fail('Result of test "%s" is unexpected; expected: "%s"/%s, got: "%s"/%s', [aTestName, aResult.fString, IntToStr(aResult.fValue), rescls.fString, IntToStr(rescls.fValue)]);