tests.rtti.invoke.pas 70 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799
  1. unit tests.rtti.invoke;
  2. {$ifdef fpc}
  3. {$mode objfpc}{$H+}
  4. {$endif}
  5. {.$define debug}
  6. interface
  7. uses
  8. {$IFDEF FPC}
  9. fpcunit,testregistry, testutils,
  10. {$ELSE FPC}
  11. TestFramework,
  12. {$ENDIF FPC}
  13. sysutils, typinfo, Rtti;
  14. type
  15. {$ifndef fpc}
  16. CodePointer = Pointer;
  17. {$endif}
  18. TTestInvoke = class(TTestCase)
  19. private type
  20. TInvokeFlag = (
  21. ifStatic,
  22. ifConstructor
  23. );
  24. TInvokeFlags = set of TInvokeFlag;
  25. private
  26. function EqualValues(aValue1, aValue2: TValue): Boolean;
  27. function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
  28. procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
  29. procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
  30. procedure DoStaticInvokeTestUnicodeStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString);
  31. procedure DoIntfInvoke(aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  32. procedure DoMethodInvoke(aInst: TObject; aMethod: TMethod; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  33. procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  34. {$ifndef InLazIDE}
  35. {$ifdef fpc}generic{$endif} procedure GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  36. {$ifdef fpc}generic{$endif} procedure GenDoProcvarInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  37. {$ifdef fpc}generic{$endif} function GetRecValue<T>(aReverse: Boolean): TValue;
  38. {$endif}
  39. {$ifdef fpc}
  40. procedure Status(const aMsg: String);
  41. {$endif}
  42. published
  43. procedure TestShortString;
  44. procedure TestAnsiString;
  45. procedure TestWideString;
  46. procedure TestUnicodeString;
  47. procedure TestLongInt;
  48. procedure TestInt64;
  49. procedure TestTObject;
  50. procedure TestIntfMethods;
  51. procedure TestIntfMethodsRecs;
  52. procedure TestMethodVars;
  53. procedure TestMethodVarsRecs;
  54. procedure TestProcVars;
  55. procedure TestProcVarsRecs;
  56. end;
  57. {$ifndef fpc}
  58. TValueHelper = record helper for TValue
  59. function AsUnicodeString: UnicodeString;
  60. function AsAnsiString: AnsiString;
  61. end;
  62. {$endif}
  63. implementation
  64. {$ifndef fpc}
  65. function TValueHelper.AsUnicodeString: UnicodeString;
  66. begin
  67. Result := UnicodeString(AsString);
  68. end;
  69. function TValueHelper.AsAnsiString: AnsiString;
  70. begin
  71. Result := AnsiString(AsString);
  72. end;
  73. {$endif}
  74. function TTestInvoke.EqualValues(aValue1, aValue2: TValue): Boolean;
  75. var
  76. td1, td2: PTypeData;
  77. i: SizeInt;
  78. begin
  79. {$ifdef debug}
  80. Writeln('Empty: ', aValue1.IsEmpty, ' ', aValue2.IsEmpty);
  81. Writeln('Kind: ', aValue1.Kind, ' ', aValue2.Kind);
  82. Writeln('Array: ', aValue1.IsArray, ' ', aValue2.IsArray);
  83. {$endif}
  84. if aValue1.IsEmpty and aValue2.IsEmpty then
  85. Result := True
  86. else if aValue1.IsEmpty and not aValue2.IsEmpty then
  87. Result := False
  88. else if not aValue1.IsEmpty and aValue2.IsEmpty then
  89. Result := False
  90. else if aValue1.IsArray and aValue2.IsArray then begin
  91. if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
  92. Result := True;
  93. for i := 0 to aValue1.GetArrayLength - 1 do
  94. if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
  95. Writeln('Element ', i, ' differs: ', HexStr(aValue1.GetArrayElement(i).AsOrdinal, 4), ' ', HexStr(aValue2.GetArrayElement(i).AsOrdinal, 4));
  96. Result := False;
  97. Break;
  98. end;
  99. end else
  100. Result := False;
  101. end else if aValue1.Kind = aValue2.Kind then begin
  102. td1 := aValue1.TypeData;
  103. td2 := aValue2.TypeData;
  104. case aValue1.Kind of
  105. tkBool:
  106. Result := aValue1.AsBoolean xor not aValue2.AsBoolean;
  107. tkSet:
  108. if td1^.SetSize = td2^.SetSize then
  109. if td1^.SetSize < SizeOf(SizeInt) then
  110. Result := aValue1.AsOrdinal = aValue2.AsOrdinal
  111. else
  112. Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, td1^.SetSize)
  113. else
  114. Result := False;
  115. tkEnumeration,
  116. tkChar,
  117. tkWChar,
  118. tkUChar,
  119. tkInt64,
  120. tkInteger:
  121. Result := aValue1.AsOrdinal = aValue2.AsOrdinal;
  122. tkQWord:
  123. Result := aValue1.AsUInt64 = aValue2.AsUInt64;
  124. tkFloat:
  125. if td1^.FloatType <> td2^.FloatType then
  126. Result := False
  127. else begin
  128. case td1^.FloatType of
  129. ftSingle,
  130. ftDouble,
  131. ftExtended:
  132. Result := aValue1.AsExtended = aValue2.AsExtended;
  133. ftComp:
  134. Result := aValue1.AsInt64 = aValue2.AsInt64;
  135. ftCurr:
  136. Result := aValue1.AsCurrency = aValue2.AsCurrency;
  137. end;
  138. end;
  139. tkSString,
  140. tkUString,
  141. tkAString,
  142. tkWString:
  143. Result := aValue1.AsString = aValue2.AsString;
  144. tkDynArray,
  145. tkArray:
  146. if aValue1.GetArrayLength = aValue2.GetArrayLength then begin
  147. Result := True;
  148. for i := 0 to aValue1.GetArrayLength - 1 do
  149. if not EqualValues(aValue1.GetArrayElement(i), aValue2.GetArrayElement(i)) then begin
  150. Result := False;
  151. Break;
  152. end;
  153. end else
  154. Result := False;
  155. tkClass,
  156. tkClassRef,
  157. tkInterface,
  158. tkInterfaceRaw,
  159. tkPointer:
  160. Result := PPointer(aValue1.GetReferenceToRawData)^ = PPointer(aValue2.GetReferenceToRawData)^;
  161. tkProcVar:
  162. Result := PCodePointer(aValue1.GetReferenceToRawData)^ = PCodePointer(aValue2.GetReferenceToRawData)^;
  163. tkRecord,
  164. tkObject,
  165. tkMethod,
  166. tkVariant: begin
  167. if aValue1.DataSize = aValue2.DataSize then
  168. Result := CompareMem(aValue1.GetReferenceToRawData, aValue2.GetReferenceToRawData, aValue1.DataSize)
  169. else
  170. Result := False;
  171. end
  172. else
  173. Result := False;
  174. end;
  175. end else
  176. Result := False;
  177. end;
  178. function TTestInvoke.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
  179. aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
  180. begin
  181. try
  182. Result := Rtti.Invoke(aCodeAddress, aArgs, aCallConv, aResultType, ifStatic in aFlags, ifConstructor in aFlags);
  183. aValid := True;
  184. except
  185. on e: ENotImplemented do begin
  186. Status('Ignoring unimplemented functionality of test');
  187. aValid := False;
  188. end else
  189. raise;
  190. end;
  191. end;
  192. procedure TTestInvoke.DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
  193. var
  194. resval: TValue;
  195. valid: Boolean;
  196. begin
  197. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  198. if valid and Assigned(aReturnType) and (resval.AsOrdinal <> aResult) then begin
  199. Fail('Result of test "%s" is unexpected; expected: %s, got: %s', [aTestName, IntToStr(aResult), IntToStr(resval.AsOrdinal)]);
  200. end;
  201. end;
  202. procedure TTestInvoke.DoStaticInvokeTestAnsiStringCompare(
  203. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  204. aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
  205. var
  206. resval: TValue;
  207. valid: Boolean;
  208. begin
  209. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  210. if valid and Assigned(aReturnType) and (resval.AsAnsiString <> aResult) then begin
  211. Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
  212. end;
  213. end;
  214. procedure TTestInvoke.DoStaticInvokeTestUnicodeStringCompare(
  215. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  216. aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString
  217. );
  218. var
  219. resval: TValue;
  220. valid: Boolean;
  221. begin
  222. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  223. if valid and Assigned(aReturnType) and (resval.AsUnicodeString <> aResult) then begin
  224. Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
  225. end;
  226. end;
  227. {$ifdef fpc}
  228. procedure TTestInvoke.Status(const aMsg: String);
  229. begin
  230. {$ifdef debug}
  231. Writeln(aMsg);
  232. {$endif}
  233. end;
  234. {$endif}
  235. function TestShortStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; register;
  236. begin
  237. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  238. end;
  239. function TestShortStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; cdecl;
  240. begin
  241. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  242. end;
  243. function TestShortStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; stdcall;
  244. begin
  245. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  246. end;
  247. function TestShortStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; pascal;
  248. begin
  249. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  250. end;
  251. procedure TTestInvoke.TestShortString;
  252. const
  253. strs: array[0..5] of ShortString = (
  254. 'This ',
  255. 'is a ',
  256. 'test ',
  257. 'of ',
  258. 'shortstring ',
  259. 'concatenation'
  260. );
  261. var
  262. values: TValueArray;
  263. resstr: ShortString;
  264. i: LongInt;
  265. begin
  266. SetLength(values, Length(strs));
  267. resstr := '';
  268. for i := Low(values) to High(values) do begin
  269. TValue.Make(@strs[i], TypeInfo(ShortString), values[i]);
  270. resstr := resstr + strs[i];
  271. end;
  272. DoStaticInvokeTestAnsiStringCompare('ShortString Register', @TestShortStringRegister, ccReg, values, TypeInfo(ShortString), resstr);
  273. DoStaticInvokeTestAnsiStringCompare('ShortString Cdecl', @TestShortStringCdecl, ccCdecl, values, TypeInfo(ShortString), resstr);
  274. DoStaticInvokeTestAnsiStringCompare('ShortString StdCall', @TestShortStringStdCall, ccStdCall, values, TypeInfo(ShortString), resstr);
  275. DoStaticInvokeTestAnsiStringCompare('ShortString Pascal', @TestShortStringPascal, ccPascal, values, TypeInfo(ShortString), resstr);
  276. end;
  277. function TestAnsiStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; register;
  278. begin
  279. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  280. end;
  281. function TestAnsiStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; cdecl;
  282. begin
  283. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  284. end;
  285. function TestAnsiStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; stdcall;
  286. begin
  287. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  288. end;
  289. function TestAnsiStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; pascal;
  290. begin
  291. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  292. end;
  293. procedure TTestInvoke.TestAnsiString;
  294. const
  295. strs: array[0..5] of AnsiString = (
  296. 'This ',
  297. 'is a ',
  298. 'test ',
  299. 'of ',
  300. 'AnsiString ',
  301. 'concatenation'
  302. );
  303. var
  304. values: TValueArray;
  305. resstr: AnsiString;
  306. i: LongInt;
  307. begin
  308. SetLength(values, Length(strs));
  309. resstr := '';
  310. for i := Low(values) to High(values) do begin
  311. TValue.Make(@strs[i], TypeInfo(AnsiString), values[i]);
  312. resstr := resstr + strs[i];
  313. end;
  314. DoStaticInvokeTestAnsiStringCompare('AnsiString Register', @TestAnsiStringRegister, ccReg, values, TypeInfo(AnsiString), resstr);
  315. DoStaticInvokeTestAnsiStringCompare('AnsiString Cdecl', @TestAnsiStringCdecl, ccCdecl, values, TypeInfo(AnsiString), resstr);
  316. DoStaticInvokeTestAnsiStringCompare('AnsiString StdCall', @TestAnsiStringStdCall, ccStdCall, values, TypeInfo(AnsiString), resstr);
  317. DoStaticInvokeTestAnsiStringCompare('AnsiString Pascal', @TestAnsiStringPascal, ccPascal, values, TypeInfo(AnsiString), resstr);
  318. end;
  319. function TestWideStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; register;
  320. begin
  321. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  322. end;
  323. function TestWideStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; cdecl;
  324. begin
  325. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  326. end;
  327. function TestWideStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; stdcall;
  328. begin
  329. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  330. end;
  331. function TestWideStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; pascal;
  332. begin
  333. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  334. end;
  335. procedure TTestInvoke.TestWideString;
  336. const
  337. strs: array[0..5] of WideString = (
  338. 'This ',
  339. 'is a ',
  340. 'test ',
  341. 'of ',
  342. 'WideString ',
  343. 'concatenation'
  344. );
  345. var
  346. values: TValueArray;
  347. resstr: WideString;
  348. i: LongInt;
  349. begin
  350. SetLength(values, Length(strs));
  351. resstr := '';
  352. for i := Low(values) to High(values) do begin
  353. TValue.Make(@strs[i], TypeInfo(WideString), values[i]);
  354. resstr := resstr + strs[i];
  355. end;
  356. DoStaticInvokeTestUnicodeStringCompare('WideString Register', @TestWideStringRegister, ccReg, values, TypeInfo(WideString), resstr);
  357. DoStaticInvokeTestUnicodeStringCompare('WideString Cdecl', @TestWideStringCdecl, ccCdecl, values, TypeInfo(WideString), resstr);
  358. DoStaticInvokeTestUnicodeStringCompare('WideString StdCall', @TestWideStringStdCall, ccStdCall, values, TypeInfo(WideString), resstr);
  359. DoStaticInvokeTestUnicodeStringCompare('WideString Pascal', @TestWideStringPascal, ccPascal, values, TypeInfo(WideString), resstr);
  360. end;
  361. function TestUnicodeStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; register;
  362. begin
  363. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  364. end;
  365. function TestUnicodeStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; cdecl;
  366. begin
  367. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  368. end;
  369. function TestUnicodeStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; stdcall;
  370. begin
  371. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  372. end;
  373. function TestUnicodeStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; pascal;
  374. begin
  375. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  376. end;
  377. procedure TTestInvoke.TestUnicodeString;
  378. const
  379. strs: array[0..5] of UnicodeString = (
  380. 'This ',
  381. 'is a ',
  382. 'test ',
  383. 'of ',
  384. 'UnicodeString ',
  385. 'concatenation'
  386. );
  387. var
  388. values: TValueArray;
  389. resstr: UnicodeString;
  390. i: LongInt;
  391. begin
  392. SetLength(values, Length(strs));
  393. resstr := '';
  394. for i := Low(values) to High(values) do begin
  395. TValue.Make(@strs[i], TypeInfo(UnicodeString), values[i]);
  396. resstr := resstr + strs[i];
  397. end;
  398. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Register', @TestUnicodeStringRegister, ccReg, values, TypeInfo(UnicodeString), resstr);
  399. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Cdecl', @TestUnicodeStringCdecl, ccCdecl, values, TypeInfo(UnicodeString), resstr);
  400. DoStaticInvokeTestUnicodeStringCompare('UnicodeString StdCall', @TestUnicodeStringStdCall, ccStdCall, values, TypeInfo(UnicodeString), resstr);
  401. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Pascal', @TestUnicodeStringPascal, ccPascal, values, TypeInfo(UnicodeString), resstr);
  402. end;
  403. function TestLongIntRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; register;
  404. begin
  405. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  406. end;
  407. function TestLongIntCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; cdecl;
  408. begin
  409. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  410. end;
  411. function TestLongIntStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; stdcall;
  412. begin
  413. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  414. end;
  415. function TestLongIntPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; pascal;
  416. begin
  417. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  418. end;
  419. procedure TTestInvoke.TestLongInt;
  420. const
  421. vals: array[0..5] of LongInt = (
  422. 8,
  423. 4,
  424. 7,
  425. 3,
  426. 6,
  427. 1
  428. );
  429. var
  430. values: TValueArray;
  431. resval, factor: LongInt;
  432. i: LongInt;
  433. begin
  434. SetLength(values, Length(vals));
  435. resval := 0;
  436. factor := 1;
  437. for i := Low(values) to High(values) do begin
  438. TValue.Make(@vals[i], TypeInfo(LongInt), values[i]);
  439. resval := resval + vals[i] * factor;
  440. factor := factor * 10;
  441. end;
  442. DoStaticInvokeTestOrdinalCompare('LongInt Register', @TestLongIntRegister, ccReg, values, TypeInfo(LongInt), resval);
  443. DoStaticInvokeTestOrdinalCompare('LongInt Cdecl', @TestLongIntCdecl, ccCdecl, values, TypeInfo(LongInt), resval);
  444. DoStaticInvokeTestOrdinalCompare('LongInt StdCall', @TestLongIntStdCall, ccStdCall, values, TypeInfo(LongInt), resval);
  445. DoStaticInvokeTestOrdinalCompare('LongInt Pascal', @TestLongIntPascal, ccPascal, values, TypeInfo(LongInt), resval);
  446. end;
  447. function TestInt64Register(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; register;
  448. begin
  449. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  450. end;
  451. function TestInt64Cdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; cdecl;
  452. begin
  453. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  454. end;
  455. function TestInt64StdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; stdcall;
  456. begin
  457. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  458. end;
  459. function TestInt64Pascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; pascal;
  460. begin
  461. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  462. end;
  463. procedure TTestInvoke.TestInt64;
  464. const
  465. vals: array[0..5] of Int64 = (
  466. 8,
  467. 4,
  468. 7,
  469. 3,
  470. 6,
  471. 1
  472. );
  473. var
  474. values: TValueArray;
  475. resval, factor: Int64;
  476. i: LongInt;
  477. begin
  478. SetLength(values, Length(vals));
  479. resval := 0;
  480. factor := 1;
  481. for i := Low(values) to High(values) do begin
  482. TValue.Make(@vals[i], TypeInfo(Int64), values[i]);
  483. resval := resval + vals[i] * factor;
  484. factor := factor * 100;
  485. end;
  486. DoStaticInvokeTestOrdinalCompare('Int64 Register', @TestInt64Register, ccReg, values, TypeInfo(Int64), resval);
  487. DoStaticInvokeTestOrdinalCompare('Int64 Cdecl', @TestInt64Cdecl, ccCdecl, values, TypeInfo(Int64), resval);
  488. DoStaticInvokeTestOrdinalCompare('Int64 StdCall', @TestInt64StdCall, ccStdCall, values, TypeInfo(Int64), resval);
  489. DoStaticInvokeTestOrdinalCompare('Int64 Pascal', @TestInt64Pascal, ccPascal, values, TypeInfo(Int64), resval);
  490. end;
  491. type
  492. TTestClass = class
  493. fString: String;
  494. fValue: LongInt;
  495. end;
  496. function TestTTestClassRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; register;
  497. begin
  498. Result := TTestClass.Create;
  499. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  500. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  501. end;
  502. function TestTTestClassCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; cdecl;
  503. begin
  504. Result := TTestClass.Create;
  505. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  506. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  507. end;
  508. function TestTTestClassStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; stdcall;
  509. begin
  510. Result := TTestClass.Create;
  511. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  512. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  513. end;
  514. function TestTTestClassPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; pascal;
  515. begin
  516. Result := TTestClass.Create;
  517. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  518. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  519. end;
  520. procedure TTestInvoke.TestTObject;
  521. procedure DoStaticInvokeTestClassCompare(
  522. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  523. aValues: TValueArray; aReturnType: PTypeInfo; aResult: TTestClass
  524. );
  525. var
  526. resval: TValue;
  527. rescls: TTestClass;
  528. valid: Boolean;
  529. begin
  530. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  531. if valid and Assigned(aReturnType) then begin
  532. rescls := TTestClass(PPointer(resval.GetReferenceToRawData)^);
  533. if (rescls.fString <> aResult.fString) or (rescls.fValue <> aResult.fValue) then
  534. Fail('Result of test "%s" is unexpected; expected: "%s"/%s, got: "%s"/%s', [aTestName, aResult.fString, IntToStr(aResult.fValue), rescls.fString, IntToStr(rescls.fValue)]);
  535. end;
  536. end;
  537. const
  538. strs: array[0..5] of AnsiString = (
  539. 'This ',
  540. 'is a ',
  541. 'test ',
  542. 'of ',
  543. 'AnsiString ',
  544. 'concatenation'
  545. );
  546. vals: array[0..5] of Int64 = (
  547. 8,
  548. 4,
  549. 7,
  550. 3,
  551. 6,
  552. 1
  553. );
  554. var
  555. values: TValueArray;
  556. t, rescls: TTestClass;
  557. i, factor: LongInt;
  558. begin
  559. SetLength(values, Length(vals));
  560. factor := 1;
  561. rescls := TTestClass.Create;
  562. for i := Low(values) to High(values) do begin
  563. t := TTestClass.Create;
  564. t.fString := strs[i];
  565. t.fValue := vals[i];
  566. TValue.Make(@t, TypeInfo(TTestClass), values[i]);
  567. rescls.fValue := rescls.fValue + vals[i] * factor;
  568. rescls.fString := rescls.fString + strs[i];
  569. factor := factor * 10;
  570. end;
  571. DoStaticInvokeTestClassCompare('TTestClass Register', @TestTTestClassRegister, ccReg, values, TypeInfo(TTestClass), rescls);
  572. DoStaticInvokeTestClassCompare('TTestClass Cdecl', @TestTTestClassCdecl, ccCdecl, values, TypeInfo(TTestClass), rescls);
  573. DoStaticInvokeTestClassCompare('TTestClass StdCall', @TestTTestClassStdCall, ccStdCall, values, TypeInfo(TTestClass), rescls);
  574. DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls);
  575. end;
  576. type
  577. TTestRecord1 = packed record
  578. b: array[0..0] of Byte;
  579. end;
  580. TTestRecord2 = packed record
  581. b: array[0..1] of Byte;
  582. end;
  583. TTestRecord3 = packed record
  584. b: array[0..2] of Byte;
  585. end;
  586. TTestRecord4 = packed record
  587. b: array[0..3] of Byte;
  588. end;
  589. TTestRecord5 = packed record
  590. b: array[0..4] of Byte;
  591. end;
  592. TTestRecord6 = packed record
  593. b: array[0..5] of Byte;
  594. end;
  595. TTestRecord7 = packed record
  596. b: array[0..6] of Byte;
  597. end;
  598. TTestRecord8 = packed record
  599. b: array[0..7] of Byte;
  600. end;
  601. TTestRecord9 = packed record
  602. b: array[0..8] of Byte;
  603. end;
  604. TTestRecord10 = packed record
  605. b: array[0..9] of Byte;
  606. end;
  607. {$M+}
  608. ITestInterface = interface
  609. procedure Test1;
  610. function Test2: SizeInt;
  611. function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  612. procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  613. function Test5: AnsiString;
  614. function Test6: UnicodeString;
  615. function Test7: WideString;
  616. function Test8: ShortString;
  617. procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  618. procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  619. procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  620. 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);
  621. function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
  622. function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
  623. function TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
  624. function TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
  625. function TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
  626. function TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
  627. function TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
  628. function TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
  629. function TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
  630. function TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
  631. end;
  632. {$M-}
  633. TTestInterfaceClass = class(TInterfacedObject, ITestInterface)
  634. private
  635. procedure Test1;
  636. function Test2: SizeInt;
  637. function Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  638. procedure Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  639. function Test5: AnsiString;
  640. function Test6: UnicodeString;
  641. function Test7: WideString;
  642. function Test8: ShortString;
  643. procedure Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  644. procedure Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  645. procedure Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  646. 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);
  647. function TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
  648. function TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
  649. function TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
  650. function TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
  651. function TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
  652. function TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
  653. function TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
  654. function TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
  655. function TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
  656. function TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
  657. public
  658. InputArgs: array of TValue;
  659. OutputArgs: array of TValue;
  660. ResultValue: TValue;
  661. CalledMethod: SizeInt;
  662. InOutMapping: array of SizeInt;
  663. procedure Reset;
  664. public class var
  665. ProcVarInst: TTestInterfaceClass;
  666. ProcVarRecInst: TTestInterfaceClass;
  667. public const
  668. RecSizeMarker = SizeInt($80000000);
  669. end;
  670. TMethodTest1 = procedure of object;
  671. TMethodTest2 = function: SizeInt of object;
  672. TMethodTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt of object;
  673. TMethodTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString) of object;
  674. TMethodTest5 = function: AnsiString of object;
  675. TMethodTest6 = function: UnicodeString of object;
  676. TMethodTest7 = function: WideString of object;
  677. TMethodTest8 = function: ShortString of object;
  678. TMethodTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt) of object;
  679. TMethodTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString) of object;
  680. TMethodTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString) of object;
  681. 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;
  682. TMethodTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1 of object;
  683. TMethodTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2 of object;
  684. TMethodTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3 of object;
  685. TMethodTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4 of object;
  686. TMethodTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5 of object;
  687. TMethodTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6 of object;
  688. TMethodTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7 of object;
  689. TMethodTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8 of object;
  690. TMethodTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9 of object;
  691. TMethodTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10 of object;
  692. TProcVarTest1 = procedure;
  693. TProcVarTest2 = function: SizeInt;
  694. TProcVarTest3 = function(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  695. TProcVarTest4 = procedure(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  696. TProcVarTest5 = function: AnsiString;
  697. TProcVarTest6 = function: UnicodeString;
  698. TProcVarTest7 = function: WideString;
  699. TProcVarTest8 = function: ShortString;
  700. TProcVarTest9 = procedure(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  701. TProcVarTest10 = procedure(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  702. TProcVarTest11 = procedure(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  703. 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);
  704. TProcVarTestRecSize1 = function(aArg1: TTestRecord1): TTestRecord1;
  705. TProcVarTestRecSize2 = function(aArg1: TTestRecord2): TTestRecord2;
  706. TProcVarTestRecSize3 = function(aArg1: TTestRecord3): TTestRecord3;
  707. TProcVarTestRecSize4 = function(aArg1: TTestRecord4): TTestRecord4;
  708. TProcVarTestRecSize5 = function(aArg1: TTestRecord5): TTestRecord5;
  709. TProcVarTestRecSize6 = function(aArg1: TTestRecord6): TTestRecord6;
  710. TProcVarTestRecSize7 = function(aArg1: TTestRecord7): TTestRecord7;
  711. TProcVarTestRecSize8 = function(aArg1: TTestRecord8): TTestRecord8;
  712. TProcVarTestRecSize9 = function(aArg1: TTestRecord9): TTestRecord9;
  713. TProcVarTestRecSize10 = function(aArg1: TTestRecord10): TTestRecord10;
  714. procedure TTestInterfaceClass.Test1;
  715. begin
  716. SetLength(InputArgs, 0);
  717. SetLength(OutputArgs, 0);
  718. ResultValue := TValue.Empty;
  719. CalledMethod := 1;
  720. end;
  721. function TTestInterfaceClass.Test2: SizeInt;
  722. begin
  723. SetLength(InputArgs, 0);
  724. SetLength(OutputArgs, 0);
  725. Result := 42;
  726. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  727. CalledMethod := 2;
  728. end;
  729. function TTestInterfaceClass.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  730. begin
  731. SetLength(InputArgs, 10);
  732. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  733. TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
  734. TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
  735. TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
  736. TValue.Make(@aArg5, TypeInfo(aArg5), InputArgs[4]);
  737. TValue.Make(@aArg6, TypeInfo(aArg6), InputArgs[5]);
  738. TValue.Make(@aArg7, TypeInfo(aArg7), InputArgs[6]);
  739. TValue.Make(@aArg8, TypeInfo(aArg8), InputArgs[7]);
  740. TValue.Make(@aArg9, TypeInfo(aArg9), InputArgs[8]);
  741. TValue.Make(@aArg10, TypeInfo(aArg10), InputArgs[9]);
  742. SetLength(OutputArgs, 0);
  743. Result := 42;
  744. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  745. CalledMethod := 3;
  746. end;
  747. procedure TTestInterfaceClass.Test4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  748. begin
  749. SetLength(InputArgs, 4);
  750. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  751. TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
  752. TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
  753. TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
  754. SetLength(OutputArgs, 0);
  755. ResultValue := TValue.Empty;
  756. CalledMethod := 4;
  757. end;
  758. function TTestInterfaceClass.Test5: AnsiString;
  759. begin
  760. SetLength(InputArgs, 0);
  761. SetLength(OutputArgs, 0);
  762. Result := 'Hello World';
  763. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  764. CalledMethod := 5;
  765. end;
  766. function TTestInterfaceClass.Test6: UnicodeString;
  767. begin
  768. SetLength(InputArgs, 0);
  769. SetLength(OutputArgs, 0);
  770. Result := 'Hello World';
  771. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  772. CalledMethod := 6;
  773. end;
  774. function TTestInterfaceClass.Test7: WideString;
  775. begin
  776. SetLength(InputArgs, 0);
  777. SetLength(OutputArgs, 0);
  778. Result := 'Hello World';
  779. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  780. CalledMethod := 7;
  781. end;
  782. function TTestInterfaceClass.Test8: ShortString;
  783. begin
  784. SetLength(InputArgs, 0);
  785. SetLength(OutputArgs, 0);
  786. Result := 'Hello World';
  787. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  788. CalledMethod := 8;
  789. end;
  790. procedure TTestInterfaceClass.Test9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  791. begin
  792. SetLength(InputArgs, 4);
  793. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  794. TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
  795. TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
  796. TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
  797. aArg2 := $1234;
  798. aArg3 := $5678;
  799. SetLength(OutputArgs, 2);
  800. TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
  801. TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
  802. SetLength(InOutMapping, 2);
  803. InOutMapping[0] := 1;
  804. InOutMapping[1] := 2;
  805. ResultValue := TValue.Empty;
  806. CalledMethod := 9;
  807. end;
  808. procedure TTestInterfaceClass.Test10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  809. begin
  810. SetLength(InputArgs, 4);
  811. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  812. TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
  813. TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
  814. TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
  815. aArg2 := 'Foo';
  816. aArg3 := 'Bar';
  817. SetLength(OutputArgs, 2);
  818. TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
  819. TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
  820. SetLength(InOutMapping, 2);
  821. InOutMapping[0] := 1;
  822. InOutMapping[1] := 2;
  823. ResultValue := TValue.Empty;
  824. CalledMethod := 10;
  825. end;
  826. procedure TTestInterfaceClass.Test11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  827. begin
  828. SetLength(InputArgs, 4);
  829. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  830. TValue.Make(@aArg2, TypeInfo(aArg2), InputArgs[1]);
  831. TValue.Make(@aArg3, TypeInfo(aArg3), InputArgs[2]);
  832. TValue.Make(@aArg4, TypeInfo(aArg4), InputArgs[3]);
  833. aArg2 := 'Foo';
  834. aArg3 := 'Bar';
  835. SetLength(OutputArgs, 2);
  836. TValue.Make(@aArg2, TypeInfo(aArg2), OutputArgs[0]);
  837. TValue.Make(@aArg3, TypeInfo(aArg3), OutputArgs[1]);
  838. SetLength(InOutMapping, 2);
  839. InOutMapping[0] := 1;
  840. InOutMapping[1] := 2;
  841. ResultValue := TValue.Empty;
  842. CalledMethod := 11;
  843. end;
  844. 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);
  845. {$ifdef fpc}
  846. var
  847. i: SizeInt;
  848. start: SizeInt;
  849. {$endif}
  850. begin
  851. {$ifdef fpc}
  852. SetLength(InputArgs, 4);
  853. InputArgs[0] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg1);
  854. InputArgs[1] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg2);
  855. InputArgs[2] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg3);
  856. InputArgs[3] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg4);
  857. SetLength(OutputArgs, 2);
  858. start := $4321;
  859. for i := 0 to High(aArg2) do
  860. aArg2[i] := start + i;
  861. start := $9876;
  862. for i := 0 to High(aArg3) do
  863. aArg3[i] := start + i;
  864. OutputArgs[0] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg2);
  865. OutputArgs[1] := specialize OpenArrayToDynArrayValue<SizeInt>(aArg3);
  866. SetLength(InOutMapping, 2);
  867. InOutMapping[0] := 1;
  868. InOutMapping[1] := 2;
  869. ResultValue := TValue.Empty;
  870. CalledMethod := 12;
  871. {$endif}
  872. end;
  873. function TTestInterfaceClass.TestRecSize1(aArg1: TTestRecord1): TTestRecord1;
  874. var
  875. i: LongInt;
  876. begin
  877. SetLength(InputArgs, 1);
  878. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  879. SetLength(OutputArgs, 0);
  880. for i := 0 to High(aArg1.b) do
  881. Result.b[High(Result.b) - i] := aArg1.b[i];
  882. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  883. CalledMethod := 1 or RecSizeMarker;
  884. end;
  885. function TTestInterfaceClass.TestRecSize2(aArg1: TTestRecord2): TTestRecord2;
  886. var
  887. i: LongInt;
  888. begin
  889. SetLength(InputArgs, 1);
  890. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  891. SetLength(OutputArgs, 0);
  892. for i := 0 to High(aArg1.b) do
  893. Result.b[High(Result.b) - i] := aArg1.b[i];
  894. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  895. CalledMethod := 2 or RecSizeMarker;
  896. end;
  897. function TTestInterfaceClass.TestRecSize3(aArg1: TTestRecord3): TTestRecord3;
  898. var
  899. i: LongInt;
  900. begin
  901. SetLength(InputArgs, 1);
  902. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  903. SetLength(OutputArgs, 0);
  904. for i := 0 to High(aArg1.b) do
  905. Result.b[High(Result.b) - i] := aArg1.b[i];
  906. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  907. CalledMethod := 3 or RecSizeMarker;
  908. end;
  909. function TTestInterfaceClass.TestRecSize4(aArg1: TTestRecord4): TTestRecord4;
  910. var
  911. i: LongInt;
  912. begin
  913. SetLength(InputArgs, 1);
  914. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  915. SetLength(OutputArgs, 0);
  916. for i := 0 to High(aArg1.b) do
  917. Result.b[High(Result.b) - i] := aArg1.b[i];
  918. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  919. CalledMethod := 4 or RecSizeMarker;
  920. end;
  921. function TTestInterfaceClass.TestRecSize5(aArg1: TTestRecord5): TTestRecord5;
  922. var
  923. i: LongInt;
  924. begin
  925. SetLength(InputArgs, 1);
  926. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  927. SetLength(OutputArgs, 0);
  928. for i := 0 to High(aArg1.b) do
  929. Result.b[High(Result.b) - i] := aArg1.b[i];
  930. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  931. CalledMethod := 5 or RecSizeMarker;
  932. end;
  933. function TTestInterfaceClass.TestRecSize6(aArg1: TTestRecord6): TTestRecord6;
  934. var
  935. i: LongInt;
  936. begin
  937. SetLength(InputArgs, 1);
  938. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  939. SetLength(OutputArgs, 0);
  940. for i := 0 to High(aArg1.b) do
  941. Result.b[High(Result.b) - i] := aArg1.b[i];
  942. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  943. CalledMethod := 6 or RecSizeMarker;
  944. end;
  945. function TTestInterfaceClass.TestRecSize7(aArg1: TTestRecord7): TTestRecord7;
  946. var
  947. i: LongInt;
  948. begin
  949. SetLength(InputArgs, 1);
  950. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  951. SetLength(OutputArgs, 0);
  952. for i := 0 to High(aArg1.b) do
  953. Result.b[High(Result.b) - i] := aArg1.b[i];
  954. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  955. CalledMethod := 7 or RecSizeMarker;
  956. end;
  957. function TTestInterfaceClass.TestRecSize8(aArg1: TTestRecord8): TTestRecord8;
  958. var
  959. i: LongInt;
  960. begin
  961. SetLength(InputArgs, 1);
  962. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  963. SetLength(OutputArgs, 0);
  964. for i := 0 to High(aArg1.b) do
  965. Result.b[High(Result.b) - i] := aArg1.b[i];
  966. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  967. CalledMethod := 8 or RecSizeMarker;
  968. end;
  969. function TTestInterfaceClass.TestRecSize9(aArg1: TTestRecord9): TTestRecord9;
  970. var
  971. i: LongInt;
  972. begin
  973. SetLength(InputArgs, 1);
  974. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  975. SetLength(OutputArgs, 0);
  976. for i := 0 to High(aArg1.b) do
  977. Result.b[High(Result.b) - i] := aArg1.b[i];
  978. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  979. CalledMethod := 9 or RecSizeMarker;
  980. end;
  981. function TTestInterfaceClass.TestRecSize10(aArg1: TTestRecord10): TTestRecord10;
  982. var
  983. i: LongInt;
  984. begin
  985. SetLength(InputArgs, 1);
  986. TValue.Make(@aArg1, TypeInfo(aArg1), InputArgs[0]);
  987. SetLength(OutputArgs, 0);
  988. for i := 0 to High(aArg1.b) do
  989. Result.b[High(Result.b) - i] := aArg1.b[i];
  990. TValue.Make(@Result, TypeInfo(Result), ResultValue);
  991. CalledMethod := 10 or RecSizeMarker;
  992. end;
  993. procedure TTestInterfaceClass.Reset;
  994. begin
  995. InputArgs := Nil;
  996. OutputArgs := Nil;
  997. InOutMapping := Nil;
  998. ResultValue := TValue.Empty;
  999. CalledMethod := 0;
  1000. end;
  1001. procedure ProcTest1;
  1002. begin
  1003. TTestInterfaceClass.ProcVarInst.Test1;
  1004. end;
  1005. function ProcTest2: SizeInt;
  1006. begin
  1007. Result := TTestInterfaceClass.ProcVarInst.Test2;
  1008. end;
  1009. function ProcTest3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  1010. begin
  1011. Result := TTestInterfaceClass.ProcVarInst.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  1012. end;
  1013. procedure ProcTest4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  1014. begin
  1015. TTestInterfaceClass.ProcVarInst.Test4(aArg1, aArg2, aArg3, aArg4);
  1016. end;
  1017. function ProcTest5: AnsiString;
  1018. begin
  1019. Result := TTestInterfaceClass.ProcVarInst.Test5;
  1020. end;
  1021. function ProcTest6: UnicodeString;
  1022. begin
  1023. Result := TTestInterfaceClass.ProcVarInst.Test6;
  1024. end;
  1025. function ProcTest7: WideString;
  1026. begin
  1027. Result := TTestInterfaceClass.ProcVarInst.Test7;
  1028. end;
  1029. function ProcTest8: ShortString;
  1030. begin
  1031. Result := TTestInterfaceClass.ProcVarInst.Test8;
  1032. end;
  1033. procedure ProcTest9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  1034. begin
  1035. TTestInterfaceClass.ProcVarInst.Test9(aArg1, aArg2, aArg3, aArg4);
  1036. end;
  1037. procedure ProcTest10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  1038. begin
  1039. TTestInterfaceClass.ProcVarInst.Test10(aArg1, aArg2, aArg3, aArg4);
  1040. end;
  1041. procedure ProcTest11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  1042. begin
  1043. TTestInterfaceClass.ProcVarInst.Test11(aArg1, aArg2, aArg3, aArg4);
  1044. end;
  1045. 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);
  1046. begin
  1047. TTestInterfaceClass.ProcVarInst.Test12(aArg1, aArg2, aArg3, aArg4);
  1048. end;
  1049. function ProcTestRecSize1(aArg1: TTestRecord1): TTestRecord1;
  1050. begin
  1051. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize1(aArg1);
  1052. end;
  1053. function ProcTestRecSize2(aArg1: TTestRecord2): TTestRecord2;
  1054. begin
  1055. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize2(aArg1);
  1056. end;
  1057. function ProcTestRecSize3(aArg1: TTestRecord3): TTestRecord3;
  1058. begin
  1059. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize3(aArg1);
  1060. end;
  1061. function ProcTestRecSize4(aArg1: TTestRecord4): TTestRecord4;
  1062. begin
  1063. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize4(aArg1);
  1064. end;
  1065. function ProcTestRecSize5(aArg1: TTestRecord5): TTestRecord5;
  1066. begin
  1067. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize5(aArg1);
  1068. end;
  1069. function ProcTestRecSize6(aArg1: TTestRecord6): TTestRecord6;
  1070. begin
  1071. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize6(aArg1);
  1072. end;
  1073. function ProcTestRecSize7(aArg1: TTestRecord7): TTestRecord7;
  1074. begin
  1075. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize7(aArg1);
  1076. end;
  1077. function ProcTestRecSize8(aArg1: TTestRecord8): TTestRecord8;
  1078. begin
  1079. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize8(aArg1);
  1080. end;
  1081. function ProcTestRecSize9(aArg1: TTestRecord9): TTestRecord9;
  1082. begin
  1083. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize9(aArg1);
  1084. end;
  1085. function ProcTestRecSize10(aArg1: TTestRecord10): TTestRecord10;
  1086. begin
  1087. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1);
  1088. end;
  1089. function CopyValue({$ifdef fpc}constref{$else}const [ref]{$endif} aValue: TValue): TValue;
  1090. var
  1091. arrptr: Pointer;
  1092. len, i: SizeInt;
  1093. begin
  1094. if aValue.Kind = tkDynArray then begin
  1095. { we need to decouple the source reference, so we're going to be a bit
  1096. cheeky here }
  1097. len := aValue.GetArrayLength;
  1098. arrptr := Nil;
  1099. DynArraySetLength(arrptr, aValue.TypeInfo, 1, @len);
  1100. TValue.Make(@arrptr, aValue.TypeInfo, Result);
  1101. for i := 0 to len - 1 do
  1102. Result.SetArrayElement(i, aValue.GetArrayElement(i));
  1103. end else
  1104. TValue.Make(aValue.GetReferenceToRawData, aValue.TypeInfo, Result);
  1105. end;
  1106. procedure TTestInvoke.DoIntfInvoke(aIndex: SizeInt; aInputArgs,
  1107. aOutputArgs: TValueArray; aResult: TValue);
  1108. var
  1109. cls: TTestInterfaceClass;
  1110. intf: ITestInterface;
  1111. name: String;
  1112. context: TRttiContext;
  1113. t: TRttiType;
  1114. inst, res: TValue;
  1115. method: TRttiMethod;
  1116. i: SizeInt;
  1117. input: array of TValue;
  1118. begin
  1119. cls := TTestInterfaceClass.Create;
  1120. intf := cls;
  1121. TValue.Make(@intf, TypeInfo(intf), inst);
  1122. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
  1123. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
  1124. else
  1125. name := 'Test' + IntToStr(aIndex);
  1126. context := TRttiContext.Create;
  1127. try
  1128. t := context.GetType(TypeInfo(ITestInterface));
  1129. method := t.GetMethod(name);
  1130. Check(Assigned(method), 'Method not found: ' + name);
  1131. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  1132. IValueData of managed types) }
  1133. SetLength(input, Length(aInputArgs));
  1134. for i := 0 to High(input) do
  1135. input[i] := CopyValue(aInputArgs[i]);
  1136. try
  1137. res := method.Invoke(inst, aInputArgs);
  1138. except
  1139. DumpExceptionBacktrace(output);
  1140. raise;
  1141. end;
  1142. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  1143. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  1144. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  1145. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  1146. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  1147. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  1148. for i := 0 to High(aInputArgs) do begin
  1149. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  1150. end;
  1151. for i := 0 to High(aOutputArgs) do begin
  1152. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  1153. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  1154. end;
  1155. finally
  1156. context.Free;
  1157. end;
  1158. end;
  1159. procedure TTestInvoke.DoMethodInvoke(aInst: TObject; aMethod: TMethod;
  1160. aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  1161. var
  1162. cls: TTestInterfaceClass;
  1163. name: String;
  1164. context: TRttiContext;
  1165. t: TRttiType;
  1166. callable, res: TValue;
  1167. method: TRttiMethodType;
  1168. i: SizeInt;
  1169. input: array of TValue;
  1170. begin
  1171. cls := aInst as TTestInterfaceClass;
  1172. cls.Reset;
  1173. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
  1174. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
  1175. else
  1176. name := 'Test' + IntToStr(aIndex);
  1177. TValue.Make(@aMethod, aTypeInfo, callable);
  1178. context := TRttiContext.Create;
  1179. try
  1180. t := context.GetType(aTypeInfo);
  1181. Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name);
  1182. method := t as TRttiMethodType;
  1183. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  1184. IValueData of managed types) }
  1185. SetLength(input, Length(aInputArgs));
  1186. for i := 0 to High(input) do
  1187. input[i] := CopyValue(aInputArgs[i]);
  1188. res := method.Invoke(callable, aInputArgs);
  1189. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  1190. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  1191. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  1192. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  1193. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  1194. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  1195. for i := 0 to High(aInputArgs) do begin
  1196. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  1197. end;
  1198. for i := 0 to High(aOutputArgs) do begin
  1199. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  1200. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  1201. end;
  1202. finally
  1203. context.Free;
  1204. end;
  1205. end;
  1206. procedure TTestInvoke.DoProcVarInvoke(aInst: TObject; aProc: CodePointer;
  1207. aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  1208. var
  1209. cls: TTestInterfaceClass;
  1210. name: String;
  1211. context: TRttiContext;
  1212. t: TRttiType;
  1213. callable, res: TValue;
  1214. proc: TRttiProcedureType;
  1215. i: SizeInt;
  1216. input: array of TValue;
  1217. begin
  1218. cls := aInst as TTestInterfaceClass;
  1219. cls.Reset;
  1220. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
  1221. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
  1222. TTestInterfaceClass.ProcVarRecInst := cls;
  1223. end else begin
  1224. name := 'Test' + IntToStr(aIndex);
  1225. TTestInterfaceClass.ProcVarInst := cls;
  1226. end;
  1227. TValue.Make(@aProc, aTypeInfo, callable);
  1228. context := TRttiContext.Create;
  1229. try
  1230. t := context.GetType(aTypeInfo);
  1231. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  1232. proc := t as TRttiProcedureType;
  1233. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  1234. IValueData of managed types) }
  1235. SetLength(input, Length(aInputArgs));
  1236. for i := 0 to High(input) do
  1237. input[i] := CopyValue(aInputArgs[i]);
  1238. res := proc.Invoke(callable, aInputArgs);
  1239. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  1240. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  1241. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  1242. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  1243. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  1244. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  1245. for i := 0 to High(aInputArgs) do begin
  1246. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  1247. end;
  1248. for i := 0 to High(aOutputArgs) do begin
  1249. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  1250. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  1251. end;
  1252. finally
  1253. context.Free;
  1254. end;
  1255. end;
  1256. {$ifndef InLazIDE}
  1257. {$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoMethodInvoke<T>(aInst: TObject; aMethod: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  1258. begin
  1259. DoMethodInvoke(aInst, TMethod(aMethod), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
  1260. end;
  1261. {$ifdef fpc}generic{$endif} procedure TTestInvoke.GenDoProcVarInvoke<T>(aInst: TObject; aProc: T; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  1262. begin
  1263. DoProcVarInvoke(aInst, CodePointer(aProc), TypeInfo(T), aIndex, aInputArgs, aOutputArgs, aResult);
  1264. end;
  1265. {$ifdef fpc}generic{$endif} function TTestInvoke.GetRecValue<T>(aReverse: Boolean): TValue;
  1266. var
  1267. i: LongInt;
  1268. arr: array of Byte;
  1269. begin
  1270. SetLength(arr, SizeOf(T));
  1271. RandSeed := $54827982;
  1272. if not aReverse then begin
  1273. for i := 0 to High(arr) do
  1274. arr[i] := Random($ff);
  1275. end else begin
  1276. for i := High(arr) downto 0 do
  1277. arr[i] := Random($ff);
  1278. end;
  1279. TValue.Make(@arr[0], PTypeInfo(TypeInfo(T)), Result);
  1280. end;
  1281. {$endif}
  1282. function GetIntValue(aValue: SizeInt): TValue;
  1283. begin
  1284. Result := TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(aValue);
  1285. end;
  1286. function GetAnsiString(const aValue: AnsiString): TValue;
  1287. begin
  1288. Result := TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>(aValue);
  1289. end;
  1290. function GetShortString(const aValue: ShortString): TValue;
  1291. begin
  1292. Result := TValue.{$ifdef fpc}specialize{$endif}From<ShortString>(aValue);
  1293. end;
  1294. function GetSingleValue(aValue: Single): TValue;
  1295. begin
  1296. Result := TValue.{$ifdef fpc}specialize{$endif}From<Single>(aValue);
  1297. end;
  1298. function GetDoubleValue(aValue: Double): TValue;
  1299. begin
  1300. Result := TValue.{$ifdef fpc}specialize{$endif}From<Double>(aValue);
  1301. end;
  1302. function GetExtendedValue(aValue: Extended): TValue;
  1303. begin
  1304. Result := TValue.{$ifdef fpc}specialize{$endif}From<Extended>(aValue);
  1305. end;
  1306. function GetCompValue(aValue: Comp): TValue;
  1307. begin
  1308. Result := TValue.{$ifdef fpc}specialize{$endif}From<Comp>(aValue);
  1309. end;
  1310. function GetCurrencyValue(aValue: Currency): TValue;
  1311. begin
  1312. Result := TValue.{$ifdef fpc}specialize{$endif}From<Currency>(aValue);
  1313. end;
  1314. {$ifdef fpc}
  1315. function GetArray(const aArg: array of SizeInt): TValue;
  1316. begin
  1317. Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
  1318. end;
  1319. {$endif}
  1320. procedure TTestInvoke.TestIntfMethods;
  1321. begin
  1322. DoIntfInvoke(1, [], [], TValue.Empty);
  1323. DoIntfInvoke(2, [], [], TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(42));
  1324. DoIntfInvoke(3, [
  1325. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1326. ], [], GetIntValue(42));
  1327. DoIntfInvoke(4, [
  1328. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1329. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1330. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1331. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1332. ], [], TValue.Empty);
  1333. DoIntfInvoke(5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1334. DoIntfInvoke(6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1335. DoIntfInvoke(7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1336. DoIntfInvoke(8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1337. DoIntfInvoke(9, [
  1338. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1339. ], [
  1340. GetIntValue($1234), GetIntValue($5678)
  1341. ], TValue.Empty);
  1342. DoIntfInvoke(10, [
  1343. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1344. ], [
  1345. GetAnsiString('Foo'), GetAnsiString('Bar')
  1346. ], TValue.Empty);
  1347. DoIntfInvoke(11, [
  1348. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1349. ], [
  1350. GetShortString('Foo'), GetShortString('Bar')
  1351. ], TValue.Empty);
  1352. {$ifdef fpc}
  1353. DoIntfInvoke(12, [
  1354. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1355. ], [
  1356. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1357. ], TValue.Empty);
  1358. {$endif}
  1359. end;
  1360. procedure TTestInvoke.TestIntfMethodsRecs;
  1361. begin
  1362. DoIntfInvoke(1 or TTestInterfaceClass.RecSizeMarker,
  1363. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1364. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1365. DoIntfInvoke(2 or TTestInterfaceClass.RecSizeMarker,
  1366. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1367. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1368. DoIntfInvoke(3 or TTestInterfaceClass.RecSizeMarker,
  1369. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1370. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1371. DoIntfInvoke(4 or TTestInterfaceClass.RecSizeMarker,
  1372. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1373. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1374. DoIntfInvoke(5 or TTestInterfaceClass.RecSizeMarker,
  1375. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1376. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1377. DoIntfInvoke(6 or TTestInterfaceClass.RecSizeMarker,
  1378. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1379. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1380. DoIntfInvoke(7 or TTestInterfaceClass.RecSizeMarker,
  1381. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1382. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1383. DoIntfInvoke(8 or TTestInterfaceClass.RecSizeMarker,
  1384. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1385. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1386. DoIntfInvoke(9 or TTestInterfaceClass.RecSizeMarker,
  1387. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1388. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1389. DoIntfInvoke(10 or TTestInterfaceClass.RecSizeMarker,
  1390. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1391. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1392. end;
  1393. procedure TTestInvoke.TestMethodVars;
  1394. var
  1395. cls: TTestInterfaceClass;
  1396. begin
  1397. cls := TTestInterfaceClass.Create;
  1398. try
  1399. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest1>(cls, {$ifdef fpc}@{$endif}cls.Test1, 1, [], [], TValue.Empty);
  1400. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest2>(cls, {$ifdef fpc}@{$endif}cls.Test2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
  1401. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest3>(cls, {$ifdef fpc}@{$endif}cls.Test3, 3, [
  1402. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1403. ], [], GetIntValue(42));
  1404. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest4>(cls, {$ifdef fpc}@{$endif}cls.Test4, 4, [
  1405. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1406. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1407. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1408. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1409. ], [], TValue.Empty);
  1410. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest5>(cls, {$ifdef fpc}@{$endif}cls.Test5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1411. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest6>(cls, {$ifdef fpc}@{$endif}cls.Test6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1412. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest7>(cls, {$ifdef fpc}@{$endif}cls.Test7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1413. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest8>(cls, {$ifdef fpc}@{$endif}cls.Test8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1414. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest9>(cls, {$ifdef fpc}@{$endif}cls.Test9, 9, [
  1415. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1416. ], [
  1417. GetIntValue($1234), GetIntValue($5678)
  1418. ], TValue.Empty);
  1419. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest10>(cls, {$ifdef fpc}@{$endif}cls.Test10, 10, [
  1420. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1421. ], [
  1422. GetAnsiString('Foo'), GetAnsiString('Bar')
  1423. ], TValue.Empty);
  1424. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest11>(cls, {$ifdef fpc}@{$endif}cls.Test11, 11, [
  1425. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1426. ], [
  1427. GetShortString('Foo'), GetShortString('Bar')
  1428. ], TValue.Empty);
  1429. {$ifdef fpc}
  1430. specialize GenDoMethodInvoke<TMethodTest12>(cls, {$ifdef fpc}@{$endif}cls.Test12, 12, [
  1431. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1432. ], [
  1433. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1434. ], TValue.Empty);
  1435. {$endif}
  1436. finally
  1437. cls.Free;
  1438. end;
  1439. end;
  1440. procedure TTestInvoke.TestMethodVarsRecs;
  1441. var
  1442. cls: TTestInterfaceClass;
  1443. begin
  1444. cls := TTestInterfaceClass.Create;
  1445. try
  1446. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize1>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
  1447. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1448. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1449. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize2>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
  1450. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1451. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1452. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize3>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
  1453. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1454. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1455. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize4>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
  1456. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1457. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1458. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize5>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
  1459. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1460. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1461. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize6>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
  1462. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1463. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1464. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize7>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
  1465. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1466. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1467. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize8>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
  1468. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1469. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1470. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize9>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
  1471. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1472. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1473. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize10>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
  1474. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1475. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1476. finally
  1477. cls.Free;
  1478. end;
  1479. end;
  1480. procedure TTestInvoke.TestProcVars;
  1481. var
  1482. cls: TTestInterfaceClass;
  1483. begin
  1484. cls := TTestInterfaceClass.Create;
  1485. try
  1486. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest1>(cls, {$ifdef fpc}@{$endif}ProcTest1, 1, [], [], TValue.Empty);
  1487. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest2>(cls, {$ifdef fpc}@{$endif}ProcTest2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
  1488. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest3>(cls, {$ifdef fpc}@{$endif}ProcTest3, 3, [
  1489. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1490. ], [], GetIntValue(42));
  1491. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest4>(cls, {$ifdef fpc}@{$endif}ProcTest4, 4, [
  1492. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1493. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1494. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1495. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1496. ], [], TValue.Empty);
  1497. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest5>(cls, {$ifdef fpc}@{$endif}ProcTest5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1498. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest6>(cls, {$ifdef fpc}@{$endif}ProcTest6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1499. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest7>(cls, {$ifdef fpc}@{$endif}ProcTest7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1500. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest8>(cls, {$ifdef fpc}@{$endif}ProcTest8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1501. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest9>(cls, {$ifdef fpc}@{$endif}ProcTest9, 9, [
  1502. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1503. ], [
  1504. GetIntValue($1234), GetIntValue($5678)
  1505. ], TValue.Empty);
  1506. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest10>(cls, {$ifdef fpc}@{$endif}ProcTest10, 10, [
  1507. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1508. ], [
  1509. GetAnsiString('Foo'), GetAnsiString('Bar')
  1510. ], TValue.Empty);
  1511. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest11>(cls, {$ifdef fpc}@{$endif}ProcTest11, 11, [
  1512. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1513. ], [
  1514. GetShortString('Foo'), GetShortString('Bar')
  1515. ], TValue.Empty);
  1516. {$ifdef fpc}
  1517. specialize GenDoProcVarInvoke<TProcVarTest12>(cls, {$ifdef fpc}@{$endif}ProcTest12, 12, [
  1518. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1519. ], [
  1520. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1521. ], TValue.Empty);
  1522. {$endif}
  1523. finally
  1524. cls.Free;
  1525. end;
  1526. end;
  1527. procedure TTestInvoke.TestProcVarsRecs;
  1528. var
  1529. cls: TTestInterfaceClass;
  1530. begin
  1531. cls := TTestInterfaceClass.Create;
  1532. try
  1533. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize1>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
  1534. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1535. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1536. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize2>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
  1537. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1538. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1539. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize3>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
  1540. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1541. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1542. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize4>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
  1543. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1544. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1545. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize5>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
  1546. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1547. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1548. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize6>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
  1549. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1550. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1551. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize7>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
  1552. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1553. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1554. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize8>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
  1555. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1556. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1557. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize9>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
  1558. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1559. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1560. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize10>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
  1561. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1562. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1563. finally
  1564. cls.Free;
  1565. end;
  1566. end;
  1567. begin
  1568. {$ifdef fpc}
  1569. RegisterTest(TTestInvoke);
  1570. {$else fpc}
  1571. RegisterTest(TTestInvoke.Suite);
  1572. {$endif fpc}
  1573. end.