12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799 |
- unit tests.rtti.invoke;
- {$ifdef fpc}
- {$mode objfpc}{$H+}
- {$endif}
- {.$define debug}
- interface
- uses
- {$IFDEF FPC}
- fpcunit,testregistry, testutils,
- {$ELSE FPC}
- TestFramework,
- {$ENDIF FPC}
- sysutils, typinfo, Rtti;
- type
- {$ifndef fpc}
- CodePointer = Pointer;
- {$endif}
- TTestInvoke = class(TTestCase)
- private type
- TInvokeFlag = (
- ifStatic,
- ifConstructor
- );
- TInvokeFlags = set of TInvokeFlag;
- private
- function EqualValues(aValue1, aValue2: TValue): Boolean;
- 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);
- procedure DoIntfInvoke(aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- procedure DoMethodInvoke(aInst: TObject; aMethod: TMethod; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- {$ifndef InLazIDE}
- {$ifdef fpc}generic{$endif} procedure GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- {$ifdef fpc}generic{$endif} procedure GenDoProcvarInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- {$ifdef fpc}generic{$endif} function GetRecValue<T>(aReverse: Boolean): TValue;
- {$endif}
- {$ifdef fpc}
- procedure Status(const aMsg: String);
- {$endif}
- published
- procedure TestShortString;
- procedure TestAnsiString;
- procedure TestWideString;
- procedure TestUnicodeString;
- procedure TestLongInt;
- procedure TestInt64;
- procedure TestTObject;
- procedure TestIntfMethods;
- procedure TestIntfMethodsRecs;
- procedure TestMethodVars;
- procedure TestMethodVarsRecs;
- procedure TestProcVars;
- procedure TestProcVarsRecs;
- end;
- {$ifndef fpc}
- TValueHelper = record helper for TValue
- function AsUnicodeString: UnicodeString;
- function AsAnsiString: AnsiString;
- end;
- {$endif}
- implementation
- {$ifndef fpc}
- function TValueHelper.AsUnicodeString: UnicodeString;
- begin
- Result := UnicodeString(AsString);
- end;
- function TValueHelper.AsAnsiString: AnsiString;
- begin
- Result := AnsiString(AsString);
- end;
- {$endif}
- function TTestInvoke.EqualValues(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 TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
- 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 begin
- Status('Ignoring unimplemented functionality of test');
- aValid := False;
- end else
- raise;
- end;
- 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], 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;
- procedure TTestInvoke.DoStaticInvokeTestAnsiStringCompare(
- const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
- aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
- var
- resval: TValue;
- valid: Boolean;
- 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;
- procedure TTestInvoke.DoStaticInvokeTestUnicodeStringCompare(
- const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
- aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString
- );
- var
- resval: TValue;
- valid: Boolean;
- 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;
- {$ifdef fpc}
- procedure TTestInvoke.Status(const aMsg: String);
- begin
- {$ifdef debug}
- Writeln(aMsg);
- {$endif}
- end;
- {$endif}
- function TestShortStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; register;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestShortStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; cdecl;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestShortStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; stdcall;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestShortStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; pascal;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- procedure TTestInvoke.TestShortString;
- const
- strs: array[0..5] of ShortString = (
- 'This ',
- 'is a ',
- 'test ',
- 'of ',
- 'shortstring ',
- 'concatenation'
- );
- var
- values: TValueArray;
- resstr: ShortString;
- i: LongInt;
- begin
- SetLength(values, Length(strs));
- resstr := '';
- for i := Low(values) to High(values) do begin
- TValue.Make(@strs[i], TypeInfo(ShortString), values[i]);
- resstr := resstr + strs[i];
- end;
- DoStaticInvokeTestAnsiStringCompare('ShortString Register', @TestShortStringRegister, ccReg, values, TypeInfo(ShortString), resstr);
- DoStaticInvokeTestAnsiStringCompare('ShortString Cdecl', @TestShortStringCdecl, ccCdecl, values, TypeInfo(ShortString), resstr);
- DoStaticInvokeTestAnsiStringCompare('ShortString StdCall', @TestShortStringStdCall, ccStdCall, values, TypeInfo(ShortString), resstr);
- DoStaticInvokeTestAnsiStringCompare('ShortString Pascal', @TestShortStringPascal, ccPascal, values, TypeInfo(ShortString), resstr);
- end;
- function TestAnsiStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; register;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestAnsiStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; cdecl;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestAnsiStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; stdcall;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestAnsiStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; pascal;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- procedure TTestInvoke.TestAnsiString;
- const
- strs: array[0..5] of AnsiString = (
- 'This ',
- 'is a ',
- 'test ',
- 'of ',
- 'AnsiString ',
- 'concatenation'
- );
- var
- values: TValueArray;
- resstr: AnsiString;
- i: LongInt;
- begin
- SetLength(values, Length(strs));
- resstr := '';
- for i := Low(values) to High(values) do begin
- TValue.Make(@strs[i], TypeInfo(AnsiString), values[i]);
- resstr := resstr + strs[i];
- end;
- DoStaticInvokeTestAnsiStringCompare('AnsiString Register', @TestAnsiStringRegister, ccReg, values, TypeInfo(AnsiString), resstr);
- DoStaticInvokeTestAnsiStringCompare('AnsiString Cdecl', @TestAnsiStringCdecl, ccCdecl, values, TypeInfo(AnsiString), resstr);
- DoStaticInvokeTestAnsiStringCompare('AnsiString StdCall', @TestAnsiStringStdCall, ccStdCall, values, TypeInfo(AnsiString), resstr);
- DoStaticInvokeTestAnsiStringCompare('AnsiString Pascal', @TestAnsiStringPascal, ccPascal, values, TypeInfo(AnsiString), resstr);
- end;
- function TestWideStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; register;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestWideStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; cdecl;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestWideStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; stdcall;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestWideStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; pascal;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- procedure TTestInvoke.TestWideString;
- const
- strs: array[0..5] of WideString = (
- 'This ',
- 'is a ',
- 'test ',
- 'of ',
- 'WideString ',
- 'concatenation'
- );
- var
- values: TValueArray;
- resstr: WideString;
- i: LongInt;
- begin
- SetLength(values, Length(strs));
- resstr := '';
- for i := Low(values) to High(values) do begin
- TValue.Make(@strs[i], TypeInfo(WideString), values[i]);
- resstr := resstr + strs[i];
- end;
- DoStaticInvokeTestUnicodeStringCompare('WideString Register', @TestWideStringRegister, ccReg, values, TypeInfo(WideString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('WideString Cdecl', @TestWideStringCdecl, ccCdecl, values, TypeInfo(WideString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('WideString StdCall', @TestWideStringStdCall, ccStdCall, values, TypeInfo(WideString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('WideString Pascal', @TestWideStringPascal, ccPascal, values, TypeInfo(WideString), resstr);
- end;
- function TestUnicodeStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; register;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestUnicodeStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; cdecl;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestUnicodeStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; stdcall;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- function TestUnicodeStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; pascal;
- begin
- Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
- end;
- procedure TTestInvoke.TestUnicodeString;
- const
- strs: array[0..5] of UnicodeString = (
- 'This ',
- 'is a ',
- 'test ',
- 'of ',
- 'UnicodeString ',
- 'concatenation'
- );
- var
- values: TValueArray;
- resstr: UnicodeString;
- i: LongInt;
- begin
- SetLength(values, Length(strs));
- resstr := '';
- for i := Low(values) to High(values) do begin
- TValue.Make(@strs[i], TypeInfo(UnicodeString), values[i]);
- resstr := resstr + strs[i];
- end;
- DoStaticInvokeTestUnicodeStringCompare('UnicodeString Register', @TestUnicodeStringRegister, ccReg, values, TypeInfo(UnicodeString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('UnicodeString Cdecl', @TestUnicodeStringCdecl, ccCdecl, values, TypeInfo(UnicodeString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('UnicodeString StdCall', @TestUnicodeStringStdCall, ccStdCall, values, TypeInfo(UnicodeString), resstr);
- DoStaticInvokeTestUnicodeStringCompare('UnicodeString Pascal', @TestUnicodeStringPascal, ccPascal, values, TypeInfo(UnicodeString), resstr);
- end;
- function TestLongIntRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; register;
- begin
- Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
- end;
- function TestLongIntCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; cdecl;
- begin
- Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
- end;
- function TestLongIntStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; stdcall;
- begin
- Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
- end;
- function TestLongIntPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; pascal;
- begin
- Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
- end;
- procedure TTestInvoke.TestLongInt;
- const
- vals: array[0..5] of LongInt = (
- 8,
- 4,
- 7,
- 3,
- 6,
- 1
- );
- var
- values: TValueArray;
- resval, factor: LongInt;
- i: LongInt;
- begin
- SetLength(values, Length(vals));
- resval := 0;
- factor := 1;
- for i := Low(values) to High(values) do begin
- TValue.Make(@vals[i], TypeInfo(LongInt), values[i]);
- resval := resval + vals[i] * factor;
- factor := factor * 10;
- end;
- DoStaticInvokeTestOrdinalCompare('LongInt Register', @TestLongIntRegister, ccReg, values, TypeInfo(LongInt), resval);
- DoStaticInvokeTestOrdinalCompare('LongInt Cdecl', @TestLongIntCdecl, ccCdecl, values, TypeInfo(LongInt), resval);
- DoStaticInvokeTestOrdinalCompare('LongInt StdCall', @TestLongIntStdCall, ccStdCall, values, TypeInfo(LongInt), resval);
- DoStaticInvokeTestOrdinalCompare('LongInt Pascal', @TestLongIntPascal, ccPascal, values, TypeInfo(LongInt), resval);
- end;
- function TestInt64Register(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; register;
- begin
- Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
- end;
- function TestInt64Cdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; cdecl;
- begin
- Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
- end;
- function TestInt64StdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; stdcall;
- begin
- Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
- end;
- function TestInt64Pascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; pascal;
- begin
- Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
- end;
- procedure TTestInvoke.TestInt64;
- const
- vals: array[0..5] of Int64 = (
- 8,
- 4,
- 7,
- 3,
- 6,
- 1
- );
- var
- values: TValueArray;
- resval, factor: Int64;
- i: LongInt;
- begin
- SetLength(values, Length(vals));
- resval := 0;
- factor := 1;
- for i := Low(values) to High(values) do begin
- TValue.Make(@vals[i], TypeInfo(Int64), values[i]);
- resval := resval + vals[i] * factor;
- factor := factor * 100;
- end;
- DoStaticInvokeTestOrdinalCompare('Int64 Register', @TestInt64Register, ccReg, values, TypeInfo(Int64), resval);
- DoStaticInvokeTestOrdinalCompare('Int64 Cdecl', @TestInt64Cdecl, ccCdecl, values, TypeInfo(Int64), resval);
- DoStaticInvokeTestOrdinalCompare('Int64 StdCall', @TestInt64StdCall, ccStdCall, values, TypeInfo(Int64), resval);
- DoStaticInvokeTestOrdinalCompare('Int64 Pascal', @TestInt64Pascal, ccPascal, values, TypeInfo(Int64), resval);
- end;
- type
- TTestClass = class
- fString: String;
- fValue: LongInt;
- end;
- function TestTTestClassRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; register;
- begin
- Result := TTestClass.Create;
- Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
- Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
- end;
- function TestTTestClassCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; cdecl;
- begin
- Result := TTestClass.Create;
- Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
- Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
- end;
- function TestTTestClassStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; stdcall;
- begin
- Result := TTestClass.Create;
- Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
- Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
- end;
- function TestTTestClassPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; pascal;
- begin
- Result := TTestClass.Create;
- Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
- Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
- end;
- procedure TTestInvoke.TestTObject;
- procedure DoStaticInvokeTestClassCompare(
- const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
- aValues: TValueArray; aReturnType: PTypeInfo; aResult: TTestClass
- );
- var
- resval: TValue;
- rescls: TTestClass;
- valid: Boolean;
- 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)]);
- end;
- end;
- const
- strs: array[0..5] of AnsiString = (
- 'This ',
- 'is a ',
- 'test ',
- 'of ',
- 'AnsiString ',
- 'concatenation'
- );
- vals: array[0..5] of Int64 = (
- 8,
- 4,
- 7,
- 3,
- 6,
- 1
- );
- var
- values: TValueArray;
- t, rescls: TTestClass;
- i, factor: LongInt;
- begin
- SetLength(values, Length(vals));
- factor := 1;
- rescls := TTestClass.Create;
- for i := Low(values) to High(values) do begin
- t := TTestClass.Create;
- t.fString := strs[i];
- t.fValue := vals[i];
- TValue.Make(@t, TypeInfo(TTestClass), values[i]);
- rescls.fValue := rescls.fValue + vals[i] * factor;
- rescls.fString := rescls.fString + strs[i];
- factor := factor * 10;
- end;
- DoStaticInvokeTestClassCompare('TTestClass Register', @TestTTestClassRegister, ccReg, values, TypeInfo(TTestClass), rescls);
- DoStaticInvokeTestClassCompare('TTestClass Cdecl', @TestTTestClassCdecl, ccCdecl, values, TypeInfo(TTestClass), rescls);
- DoStaticInvokeTestClassCompare('TTestClass StdCall', @TestTTestClassStdCall, ccStdCall, values, TypeInfo(TTestClass), rescls);
- DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls);
- end;
- type
- TTestRecord1 = packed record
- b: array[0..0] of Byte;
- end;
- TTestRecord2 = packed record
- b: array[0..1] of Byte;
- end;
- TTestRecord3 = packed record
- b: array[0..2] of Byte;
- end;
- TTestRecord4 = packed record
- b: array[0..3] of Byte;
- end;
- TTestRecord5 = packed record
- b: array[0..4] of Byte;
- end;
- TTestRecord6 = packed record
- b: array[0..5] of Byte;
- end;
- TTestRecord7 = packed record
- b: array[0..6] of Byte;
- end;
- TTestRecord8 = packed record
- b: array[0..7] of Byte;
- end;
- TTestRecord9 = packed record
- b: array[0..8] of Byte;
- end;
- TTestRecord10 = packed record
- b: array[0..9] of Byte;
- end;
- {$M+}
- ITestInterface = interface
- procedure Test1;
- function Test2: SizeInt;
- function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
- procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
- function Test5: AnsiString;
- function Test6: UnicodeString;
- function Test7: WideString;
- function Test8: ShortString;
- procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
- procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
- procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
- procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
- function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
- function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
- function TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
- function TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
- function TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
- function TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
- function TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
- function TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
- function TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
- function TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
- end;
- {$M-}
- TTestInterfaceClass = class(TInterfacedObject, ITestInterface)
- private
- procedure Test1;
- function Test2: SizeInt;
- function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
- procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
- function Test5: AnsiString;
- function Test6: UnicodeString;
- function Test7: WideString;
- function Test8: ShortString;
- procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
- procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
- procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
- procedure Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
- function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
- function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
- function TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
- function TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
- function TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
- function TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
- function TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
- function TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
- function TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
- function TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
- public
- InputArgs: array of TValue;
- OutputArgs: array of TValue;
- ResultValue: TValue;
- CalledMethod: SizeInt;
- InOutMapping: array of SizeInt;
- procedure Reset;
- public class var
- ProcVarInst: TTestInterfaceClass;
- ProcVarRecInst: TTestInterfaceClass;
- public const
- RecSizeMarker = SizeInt($80000000);
- end;
- TMethodTest1 = procedure of object;
- TMethodTest2 = function: SizeInt of object;
- TMethodTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object;
- TMethodTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString) of object;
- TMethodTest5 = function: AnsiString of object;
- TMethodTest6 = function: UnicodeString of object;
- TMethodTest7 = function: WideString of object;
- TMethodTest8 = function: ShortString of object;
- TMethodTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt) of object;
- TMethodTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString) of object;
- TMethodTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString) of object;
- TMethodTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt) of object;
- TMethodTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1 of object;
- TMethodTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2 of object;
- TMethodTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3 of object;
- TMethodTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4 of object;
- TMethodTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5 of object;
- TMethodTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6 of object;
- TMethodTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7 of object;
- TMethodTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8 of object;
- TMethodTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9 of object;
- TMethodTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10 of object;
- TProcVarTest1 = procedure;
- TProcVarTest2 = function: SizeInt;
- TProcVarTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
- TProcVarTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
- TProcVarTest5 = function: AnsiString;
- TProcVarTest6 = function: UnicodeString;
- TProcVarTest7 = function: WideString;
- TProcVarTest8 = function: ShortString;
- TProcVarTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
- TProcVarTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
- TProcVarTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
- TProcVarTest12 = procedure(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
- TProcVarTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1;
- TProcVarTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2;
- TProcVarTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3;
- TProcVarTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4;
- TProcVarTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5;
- TProcVarTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6;
- TProcVarTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7;
- TProcVarTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8;
- TProcVarTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9;
- TProcVarTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10;
- procedure TTestInterfaceClass.Test1;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- ResultValue := TValue.Empty;
- CalledMethod := 1;
- end;
- function TTestInterfaceClass.Test2: SizeInt;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- Result := 42;
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 2;
- end;
- function TTestInterfaceClass.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
- begin
- SetLength(InputArgs, 10);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
- TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
- TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
- TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
- TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
- TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
- TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
- TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
- TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
- SetLength(OutputArgs, 0);
- Result := 42;
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 3;
- end;
- procedure TTestInterfaceClass.Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
- begin
- SetLength(InputArgs, 4);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
- TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
- TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
- SetLength(OutputArgs, 0);
- ResultValue := TValue.Empty;
- CalledMethod := 4;
- end;
- function TTestInterfaceClass.Test5: AnsiString;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- Result := 'Hello World';
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 5;
- end;
- function TTestInterfaceClass.Test6: UnicodeString;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- Result := 'Hello World';
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 6;
- end;
- function TTestInterfaceClass.Test7: WideString;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- Result := 'Hello World';
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 7;
- end;
- function TTestInterfaceClass.Test8: ShortString;
- begin
- SetLength(InputArgs, 0);
- SetLength(OutputArgs, 0);
- Result := 'Hello World';
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 8;
- end;
- procedure TTestInterfaceClass.Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
- begin
- SetLength(InputArgs, 4);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
- TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
- TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
- aArg2 := $1234;
- aArg3 := $5678;
- SetLength(OutputArgs, 2);
- TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
- TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
- SetLength(InOutMapping, 2);
- InOutMapping[0] := 1;
- InOutMapping[1] := 2;
- ResultValue := TValue.Empty;
- CalledMethod := 9;
- end;
- procedure TTestInterfaceClass.Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
- begin
- SetLength(InputArgs, 4);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
- TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
- TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
- aArg2 := 'Foo';
- aArg3 := 'Bar';
- SetLength(OutputArgs, 2);
- TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
- TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
- SetLength(InOutMapping, 2);
- InOutMapping[0] := 1;
- InOutMapping[1] := 2;
- ResultValue := TValue.Empty;
- CalledMethod := 10;
- end;
- procedure TTestInterfaceClass.Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
- begin
- SetLength(InputArgs, 4);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
- TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
- TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
- aArg2 := 'Foo';
- aArg3 := 'Bar';
- SetLength(OutputArgs, 2);
- TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
- TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
- SetLength(InOutMapping, 2);
- InOutMapping[0] := 1;
- InOutMapping[1] := 2;
- ResultValue := TValue.Empty;
- CalledMethod := 11;
- end;
- procedure TTestInterfaceClass.Test12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
- {$ifdef fpc}
- var
- i: SizeInt;
- start: SizeInt;
- {$endif}
- begin
- {$ifdef fpc}
- SetLength(InputArgs, 4);
- InputArgs[0] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg1);
- InputArgs[1] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg2);
- InputArgs[2] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg3);
- InputArgs[3] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg4);
- SetLength(OutputArgs, 2);
- start := $4321;
- for i := 0 to High(aArg2) do
- aArg2[i] := start + i;
- start := $9876;
- for i := 0 to High(aArg3) do
- aArg3[i] := start + i;
- OutputArgs[0] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg2);
- OutputArgs[1] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg3);
- SetLength(InOutMapping, 2);
- InOutMapping[0] := 1;
- InOutMapping[1] := 2;
- ResultValue := TValue.Empty;
- CalledMethod := 12;
- {$endif}
- end;
- function TTestInterfaceClass.TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 1 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 2 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 3 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 4 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 5 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 6 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 7 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 8 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 9 or RecSizeMarker;
- end;
- function TTestInterfaceClass.TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
- var
- i: LongInt;
- begin
- SetLength(InputArgs, 1);
- TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
- SetLength(OutputArgs, 0);
- for i := 0 to High(aArg1.b) do
- Result.b[High(Result.b) - i] := aArg1.b[i];
- TValue.Make(@Result, TypeInfo(Result), ResultValue);
- CalledMethod := 10 or RecSizeMarker;
- end;
- procedure TTestInterfaceClass.Reset;
- begin
- InputArgs := Nil;
- OutputArgs := Nil;
- InOutMapping := Nil;
- ResultValue := TValue.Empty;
- CalledMethod := 0;
- end;
- procedure ProcTest1;
- begin
- TTestInterfaceClass.ProcVarInst.Test1;
- end;
- function ProcTest2: SizeInt;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test2;
- end;
- function ProcTest3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
- end;
- procedure ProcTest4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
- begin
- TTestInterfaceClass.ProcVarInst.Test4(aArg1, aArg2, aArg3, aArg4);
- end;
- function ProcTest5: AnsiString;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test5;
- end;
- function ProcTest6: UnicodeString;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test6;
- end;
- function ProcTest7: WideString;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test7;
- end;
- function ProcTest8: ShortString;
- begin
- Result := TTestInterfaceClass.ProcVarInst.Test8;
- end;
- procedure ProcTest9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
- begin
- TTestInterfaceClass.ProcVarInst.Test9(aArg1, aArg2, aArg3, aArg4);
- end;
- procedure ProcTest10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
- begin
- TTestInterfaceClass.ProcVarInst.Test10(aArg1, aArg2, aArg3, aArg4);
- end;
- procedure ProcTest11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
- begin
- TTestInterfaceClass.ProcVarInst.Test11(aArg1, aArg2, aArg3, aArg4);
- end;
- procedure ProcTest12(aArg1: array of SizeInt; var aArg2: array of SizeInt; out aArg3: array of SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: array of SizeInt);
- begin
- TTestInterfaceClass.ProcVarInst.Test12(aArg1, aArg2, aArg3, aArg4);
- end;
- function ProcTestRecSize1(aArg1: TTestRecord1): TTestRecord1;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize1(aArg1);
- end;
- function ProcTestRecSize2(aArg1: TTestRecord2): TTestRecord2;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize2(aArg1);
- end;
- function ProcTestRecSize3(aArg1: TTestRecord3): TTestRecord3;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize3(aArg1);
- end;
- function ProcTestRecSize4(aArg1: TTestRecord4): TTestRecord4;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize4(aArg1);
- end;
- function ProcTestRecSize5(aArg1: TTestRecord5): TTestRecord5;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize5(aArg1);
- end;
- function ProcTestRecSize6(aArg1: TTestRecord6): TTestRecord6;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize6(aArg1);
- end;
- function ProcTestRecSize7(aArg1: TTestRecord7): TTestRecord7;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize7(aArg1);
- end;
- function ProcTestRecSize8(aArg1: TTestRecord8): TTestRecord8;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize8(aArg1);
- end;
- function ProcTestRecSize9(aArg1: TTestRecord9): TTestRecord9;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize9(aArg1);
- end;
- function ProcTestRecSize10(aArg1: TTestRecord10): TTestRecord10;
- begin
- Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1);
- end;
- 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;
- procedure TTestInvoke.DoIntfInvoke(aIndex: SizeInt; aInputArgs,
- aOutputArgs: TValueArray; aResult: TValue);
- var
- cls: TTestInterfaceClass;
- intf: ITestInterface;
- name: String;
- context: TRttiContext;
- t: TRttiType;
- inst, res: TValue;
- method: TRttiMethod;
- i: SizeInt;
- input: array of TValue;
- begin
- cls := TTestInterfaceClass.Create;
- intf := cls;
- TValue.Make(@intf, TypeInfo(intf), inst);
- if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
- name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
- else
- name := 'Test' + IntToStr(aIndex);
- context := TRttiContext.Create;
- try
- t := context.GetType(TypeInfo(ITestInterface));
- method := t.GetMethod(name);
- Check(Assigned(method), 'Method not found: ' + name);
- { 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(input) do
- input[i] := CopyValue(aInputArgs[i]);
- try
- res := method.Invoke(inst, aInputArgs);
- except
- DumpExceptionBacktrace(output);
- raise;
- end;
- CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
- Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
- Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
- CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
- CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
- CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
- for i := 0 to High(aInputArgs) do begin
- Check(EqualValues(input[i], cls.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], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
- Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
- end;
- finally
- context.Free;
- end;
- end;
- procedure TTestInvoke.DoMethodInvoke(aInst: TObject; aMethod: TMethod;
- aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- var
- cls: TTestInterfaceClass;
- name: String;
- context: TRttiContext;
- t: TRttiType;
- callable, res: TValue;
- method: TRttiMethodType;
- i: SizeInt;
- input: array of TValue;
- begin
- cls := aInst as TTestInterfaceClass;
- cls.Reset;
- if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
- name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
- else
- name := 'Test' + IntToStr(aIndex);
- TValue.Make(@aMethod, aTypeInfo, callable);
- context := TRttiContext.Create;
- try
- t := context.GetType(aTypeInfo);
- Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name);
- method := t as TRttiMethodType;
- { 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(input) do
- input[i] := CopyValue(aInputArgs[i]);
- res := method.Invoke(callable, aInputArgs);
- CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
- Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
- Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
- CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
- CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
- CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
- for i := 0 to High(aInputArgs) do begin
- Check(EqualValues(input[i], cls.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], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
- Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
- end;
- finally
- context.Free;
- end;
- end;
- procedure TTestInvoke.DoProcVarInvoke(aInst: TObject; aProc: CodePointer;
- aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- var
- cls: TTestInterfaceClass;
- name: String;
- context: TRttiContext;
- t: TRttiType;
- callable, res: TValue;
- proc: TRttiProcedureType;
- i: SizeInt;
- input: array of TValue;
- begin
- cls := aInst as TTestInterfaceClass;
- cls.Reset;
- if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
- name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
- TTestInterfaceClass.ProcVarRecInst := cls;
- end else begin
- name := 'Test' + IntToStr(aIndex);
- TTestInterfaceClass.ProcVarInst := cls;
- end;
- TValue.Make(@aProc, aTypeInfo, callable);
- context := TRttiContext.Create;
- try
- t := context.GetType(aTypeInfo);
- Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
- proc := t as TRttiProcedureType;
- { 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(input) do
- input[i] := CopyValue(aInputArgs[i]);
- res := proc.Invoke(callable, aInputArgs);
- CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
- Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
- Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
- CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
- CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
- CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
- for i := 0 to High(aInputArgs) do begin
- Check(EqualValues(input[i], cls.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], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
- Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
- end;
- finally
- context.Free;
- end;
- end;
- {$ifndef InLazIDE}
- {$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- begin
- DoMethodInvoke(aInst, TMethod(aMethod), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
- end;
- {$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoProcVarInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
- begin
- DoProcVarInvoke(aInst, CodePointer(aProc), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
- end;
- {$ifdef fpc}generic{$endif} function TTestInvoke.GetRecValue<T>(aReverse: Boolean): TValue;
- var
- i: LongInt;
- arr: array of Byte;
- begin
- SetLength(arr, SizeOf(T));
- RandSeed := $54827982;
- if not aReverse then begin
- for i := 0 to High(arr) do
- arr[i] := Random($ff);
- end else begin
- for i := High(arr) downto 0 do
- arr[i] := Random($ff);
- end;
- TValue.Make(@arr[0], PTypeInfo(TypeInfo(T)), Result);
- end;
- {$endif}
- 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}
- procedure TTestInvoke.TestIntfMethods;
- begin
- DoIntfInvoke(1, [], [], TValue.Empty);
- DoIntfInvoke(2, [], [], TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(42));
- DoIntfInvoke(3, [
- GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
- ], [], GetIntValue(42));
- DoIntfInvoke(4, [
- TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
- TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
- TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
- TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
- ], [], TValue.Empty);
- DoIntfInvoke(5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
- DoIntfInvoke(6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
- DoIntfInvoke(7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
- DoIntfInvoke(8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
- DoIntfInvoke(9, [
- GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
- ], [
- GetIntValue($1234), GetIntValue($5678)
- ], TValue.Empty);
- DoIntfInvoke(10, [
- GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
- ], [
- GetAnsiString('Foo'), GetAnsiString('Bar')
- ], TValue.Empty);
- DoIntfInvoke(11, [
- GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
- ], [
- GetShortString('Foo'), GetShortString('Bar')
- ], TValue.Empty);
- {$ifdef fpc}
- DoIntfInvoke(12, [
- GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
- ], [
- GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
- ], TValue.Empty);
- {$endif}
- end;
- procedure TTestInvoke.TestIntfMethodsRecs;
- begin
- DoIntfInvoke(1 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
- DoIntfInvoke(2 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
- DoIntfInvoke(3 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
- DoIntfInvoke(4 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
- DoIntfInvoke(5 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
- DoIntfInvoke(6 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
- DoIntfInvoke(7 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
- DoIntfInvoke(8 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
- DoIntfInvoke(9 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
- DoIntfInvoke(10 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
- end;
- procedure TTestInvoke.TestMethodVars;
- var
- cls: TTestInterfaceClass;
- begin
- cls := TTestInterfaceClass.Create;
- try
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest1>(cls, {$ifdef fpc}@{$endif}cls.Test1, 1, [], [], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest2>(cls, {$ifdef fpc}@{$endif}cls.Test2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest3>(cls, {$ifdef fpc}@{$endif}cls.Test3, 3, [
- GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
- ], [], GetIntValue(42));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest4>(cls, {$ifdef fpc}@{$endif}cls.Test4, 4, [
- TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
- TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
- TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
- TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
- ], [], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest5>(cls, {$ifdef fpc}@{$endif}cls.Test5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest6>(cls, {$ifdef fpc}@{$endif}cls.Test6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest7>(cls, {$ifdef fpc}@{$endif}cls.Test7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest8>(cls, {$ifdef fpc}@{$endif}cls.Test8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest9>(cls, {$ifdef fpc}@{$endif}cls.Test9, 9, [
- GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
- ], [
- GetIntValue($1234), GetIntValue($5678)
- ], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest10>(cls, {$ifdef fpc}@{$endif}cls.Test10, 10, [
- GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
- ], [
- GetAnsiString('Foo'), GetAnsiString('Bar')
- ], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest11>(cls, {$ifdef fpc}@{$endif}cls.Test11, 11, [
- GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
- ], [
- GetShortString('Foo'), GetShortString('Bar')
- ], TValue.Empty);
- {$ifdef fpc}
- specialize GenDoMethodInvoke<TMethodTest12>(cls, {$ifdef fpc}@{$endif}cls.Test12, 12, [
- GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
- ], [
- GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
- ], TValue.Empty);
- {$endif}
- finally
- cls.Free;
- end;
- end;
- procedure TTestInvoke.TestMethodVarsRecs;
- var
- cls: TTestInterfaceClass;
- begin
- cls := TTestInterfaceClass.Create;
- try
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize1>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize2>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize3>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize4>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize5>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize6>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize7>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize8>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize9>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
- {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize10>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
- finally
- cls.Free;
- end;
- end;
- procedure TTestInvoke.TestProcVars;
- var
- cls: TTestInterfaceClass;
- begin
- cls := TTestInterfaceClass.Create;
- try
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest1>(cls, {$ifdef fpc}@{$endif}ProcTest1, 1, [], [], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest2>(cls, {$ifdef fpc}@{$endif}ProcTest2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest3>(cls, {$ifdef fpc}@{$endif}ProcTest3, 3, [
- GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
- ], [], GetIntValue(42));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest4>(cls, {$ifdef fpc}@{$endif}ProcTest4, 4, [
- TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
- TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
- TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
- TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
- ], [], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest5>(cls, {$ifdef fpc}@{$endif}ProcTest5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest6>(cls, {$ifdef fpc}@{$endif}ProcTest6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest7>(cls, {$ifdef fpc}@{$endif}ProcTest7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest8>(cls, {$ifdef fpc}@{$endif}ProcTest8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest9>(cls, {$ifdef fpc}@{$endif}ProcTest9, 9, [
- GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
- ], [
- GetIntValue($1234), GetIntValue($5678)
- ], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest10>(cls, {$ifdef fpc}@{$endif}ProcTest10, 10, [
- GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
- ], [
- GetAnsiString('Foo'), GetAnsiString('Bar')
- ], TValue.Empty);
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest11>(cls, {$ifdef fpc}@{$endif}ProcTest11, 11, [
- GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
- ], [
- GetShortString('Foo'), GetShortString('Bar')
- ], TValue.Empty);
- {$ifdef fpc}
- specialize GenDoProcVarInvoke<TProcVarTest12>(cls, {$ifdef fpc}@{$endif}ProcTest12, 12, [
- GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
- ], [
- GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
- ], TValue.Empty);
- {$endif}
- finally
- cls.Free;
- end;
- end;
- procedure TTestInvoke.TestProcVarsRecs;
- var
- cls: TTestInterfaceClass;
- begin
- cls := TTestInterfaceClass.Create;
- try
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize1>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize2>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize3>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize4>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize5>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize6>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize7>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize8>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize9>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
- {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize10>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
- [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
- {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
- finally
- cls.Free;
- end;
- end;
- begin
- {$ifdef fpc}
- RegisterTest(TTestInvoke);
- {$else fpc}
- RegisterTest(TTestInvoke.Suite);
- {$endif fpc}
- end.
|