tests.rtti.invoke.pas 69 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773
  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. {$ifdef fpc}
  1295. function GetArray(const aArg: array of SizeInt): TValue;
  1296. begin
  1297. Result := specialize OpenArrayToDynArrayValue<SizeInt>(aArg);
  1298. end;
  1299. {$endif}
  1300. procedure TTestInvoke.TestIntfMethods;
  1301. begin
  1302. DoIntfInvoke(1, [], [], TValue.Empty);
  1303. DoIntfInvoke(2, [], [], TValue.{$ifdef fpc}specialize{$endif}From<SizeInt>(42));
  1304. DoIntfInvoke(3, [
  1305. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1306. ], [], GetIntValue(42));
  1307. DoIntfInvoke(4, [
  1308. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1309. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1310. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1311. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1312. ], [], TValue.Empty);
  1313. DoIntfInvoke(5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1314. DoIntfInvoke(6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1315. DoIntfInvoke(7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1316. DoIntfInvoke(8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1317. DoIntfInvoke(9, [
  1318. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1319. ], [
  1320. GetIntValue($1234), GetIntValue($5678)
  1321. ], TValue.Empty);
  1322. DoIntfInvoke(10, [
  1323. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1324. ], [
  1325. GetAnsiString('Foo'), GetAnsiString('Bar')
  1326. ], TValue.Empty);
  1327. DoIntfInvoke(11, [
  1328. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1329. ], [
  1330. GetShortString('Foo'), GetShortString('Bar')
  1331. ], TValue.Empty);
  1332. {$ifdef fpc}
  1333. DoIntfInvoke(12, [
  1334. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1335. ], [
  1336. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1337. ], TValue.Empty);
  1338. {$endif}
  1339. end;
  1340. procedure TTestInvoke.TestIntfMethodsRecs;
  1341. begin
  1342. DoIntfInvoke(1 or TTestInterfaceClass.RecSizeMarker,
  1343. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1344. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1345. DoIntfInvoke(2 or TTestInterfaceClass.RecSizeMarker,
  1346. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1347. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1348. DoIntfInvoke(3 or TTestInterfaceClass.RecSizeMarker,
  1349. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1350. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1351. DoIntfInvoke(4 or TTestInterfaceClass.RecSizeMarker,
  1352. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1353. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1354. DoIntfInvoke(5 or TTestInterfaceClass.RecSizeMarker,
  1355. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1356. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1357. DoIntfInvoke(6 or TTestInterfaceClass.RecSizeMarker,
  1358. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1359. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1360. DoIntfInvoke(7 or TTestInterfaceClass.RecSizeMarker,
  1361. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1362. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1363. DoIntfInvoke(8 or TTestInterfaceClass.RecSizeMarker,
  1364. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1365. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1366. DoIntfInvoke(9 or TTestInterfaceClass.RecSizeMarker,
  1367. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1368. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1369. DoIntfInvoke(10 or TTestInterfaceClass.RecSizeMarker,
  1370. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1371. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1372. end;
  1373. procedure TTestInvoke.TestMethodVars;
  1374. var
  1375. cls: TTestInterfaceClass;
  1376. begin
  1377. cls := TTestInterfaceClass.Create;
  1378. try
  1379. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest1>(cls, {$ifdef fpc}@{$endif}cls.Test1, 1, [], [], TValue.Empty);
  1380. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest2>(cls, {$ifdef fpc}@{$endif}cls.Test2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
  1381. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest3>(cls, {$ifdef fpc}@{$endif}cls.Test3, 3, [
  1382. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1383. ], [], GetIntValue(42));
  1384. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest4>(cls, {$ifdef fpc}@{$endif}cls.Test4, 4, [
  1385. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1386. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1387. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1388. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1389. ], [], TValue.Empty);
  1390. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest5>(cls, {$ifdef fpc}@{$endif}cls.Test5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1391. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest6>(cls, {$ifdef fpc}@{$endif}cls.Test6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1392. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest7>(cls, {$ifdef fpc}@{$endif}cls.Test7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1393. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest8>(cls, {$ifdef fpc}@{$endif}cls.Test8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1394. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest9>(cls, {$ifdef fpc}@{$endif}cls.Test9, 9, [
  1395. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1396. ], [
  1397. GetIntValue($1234), GetIntValue($5678)
  1398. ], TValue.Empty);
  1399. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest10>(cls, {$ifdef fpc}@{$endif}cls.Test10, 10, [
  1400. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1401. ], [
  1402. GetAnsiString('Foo'), GetAnsiString('Bar')
  1403. ], TValue.Empty);
  1404. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTest11>(cls, {$ifdef fpc}@{$endif}cls.Test11, 11, [
  1405. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1406. ], [
  1407. GetShortString('Foo'), GetShortString('Bar')
  1408. ], TValue.Empty);
  1409. {$ifdef fpc}
  1410. specialize GenDoMethodInvoke<TMethodTest12>(cls, {$ifdef fpc}@{$endif}cls.Test12, 12, [
  1411. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1412. ], [
  1413. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1414. ], TValue.Empty);
  1415. {$endif}
  1416. finally
  1417. cls.Free;
  1418. end;
  1419. end;
  1420. procedure TTestInvoke.TestMethodVarsRecs;
  1421. var
  1422. cls: TTestInterfaceClass;
  1423. begin
  1424. cls := TTestInterfaceClass.Create;
  1425. try
  1426. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize1>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
  1427. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1428. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1429. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize2>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
  1430. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1431. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1432. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize3>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
  1433. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1434. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1435. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize4>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
  1436. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1437. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1438. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize5>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
  1439. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1440. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1441. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize6>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
  1442. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1443. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1444. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize7>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
  1445. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1446. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1447. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize8>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
  1448. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1449. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1450. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize9>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
  1451. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1452. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1453. {$ifdef fpc}specialize{$endif} GenDoMethodInvoke<TMethodTestRecSize10>(cls, {$ifdef fpc}@{$endif}cls.TestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
  1454. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1455. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1456. finally
  1457. cls.Free;
  1458. end;
  1459. end;
  1460. procedure TTestInvoke.TestProcVars;
  1461. var
  1462. cls: TTestInterfaceClass;
  1463. begin
  1464. cls := TTestInterfaceClass.Create;
  1465. try
  1466. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest1>(cls, {$ifdef fpc}@{$endif}ProcTest1, 1, [], [], TValue.Empty);
  1467. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest2>(cls, {$ifdef fpc}@{$endif}ProcTest2, 2, [], [], TValue.{$ifdef fpc}{$ifdef fpc}specialize{$endif}{$endif}From<SizeInt>(42));
  1468. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest3>(cls, {$ifdef fpc}@{$endif}ProcTest3, 3, [
  1469. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1470. ], [], GetIntValue(42));
  1471. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest4>(cls, {$ifdef fpc}@{$endif}ProcTest4, 4, [
  1472. TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Alpha'),
  1473. TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Beta'),
  1474. TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Gamma'),
  1475. TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Delta')
  1476. ], [], TValue.Empty);
  1477. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest5>(cls, {$ifdef fpc}@{$endif}ProcTest5, 5, [], [], TValue.{$ifdef fpc}specialize{$endif}From<AnsiString>('Hello World'));
  1478. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest6>(cls, {$ifdef fpc}@{$endif}ProcTest6, 6, [], [], TValue.{$ifdef fpc}specialize{$endif}From<UnicodeString>('Hello World'));
  1479. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest7>(cls, {$ifdef fpc}@{$endif}ProcTest7, 7, [], [], TValue.{$ifdef fpc}specialize{$endif}From<WideString>('Hello World'));
  1480. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest8>(cls, {$ifdef fpc}@{$endif}ProcTest8, 8, [], [], TValue.{$ifdef fpc}specialize{$endif}From<ShortString>('Hello World'));
  1481. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest9>(cls, {$ifdef fpc}@{$endif}ProcTest9, 9, [
  1482. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1483. ], [
  1484. GetIntValue($1234), GetIntValue($5678)
  1485. ], TValue.Empty);
  1486. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest10>(cls, {$ifdef fpc}@{$endif}ProcTest10, 10, [
  1487. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1488. ], [
  1489. GetAnsiString('Foo'), GetAnsiString('Bar')
  1490. ], TValue.Empty);
  1491. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTest11>(cls, {$ifdef fpc}@{$endif}ProcTest11, 11, [
  1492. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1493. ], [
  1494. GetShortString('Foo'), GetShortString('Bar')
  1495. ], TValue.Empty);
  1496. {$ifdef fpc}
  1497. specialize GenDoProcVarInvoke<TProcVarTest12>(cls, {$ifdef fpc}@{$endif}ProcTest12, 12, [
  1498. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1499. ], [
  1500. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1501. ], TValue.Empty);
  1502. {$endif}
  1503. finally
  1504. cls.Free;
  1505. end;
  1506. end;
  1507. procedure TTestInvoke.TestProcVarsRecs;
  1508. var
  1509. cls: TTestInterfaceClass;
  1510. begin
  1511. cls := TTestInterfaceClass.Create;
  1512. try
  1513. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize1>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize1, 1 or TTestInterfaceClass.RecSizeMarker,
  1514. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(False)], [],
  1515. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord1>(True));
  1516. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize2>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize2, 2 or TTestInterfaceClass.RecSizeMarker,
  1517. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(False)], [],
  1518. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord2>(True));
  1519. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize3>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize3, 3 or TTestInterfaceClass.RecSizeMarker,
  1520. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(False)], [],
  1521. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord3>(True));
  1522. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize4>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize4, 4 or TTestInterfaceClass.RecSizeMarker,
  1523. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(False)], [],
  1524. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord4>(True));
  1525. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize5>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize5, 5 or TTestInterfaceClass.RecSizeMarker,
  1526. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(False)], [],
  1527. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord5>(True));
  1528. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize6>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize6, 6 or TTestInterfaceClass.RecSizeMarker,
  1529. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(False)], [],
  1530. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord6>(True));
  1531. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize7>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize7, 7 or TTestInterfaceClass.RecSizeMarker,
  1532. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(False)], [],
  1533. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord7>(True));
  1534. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize8>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize8, 8 or TTestInterfaceClass.RecSizeMarker,
  1535. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(False)], [],
  1536. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord8>(True));
  1537. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize9>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize9, 9 or TTestInterfaceClass.RecSizeMarker,
  1538. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(False)], [],
  1539. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord9>(True));
  1540. {$ifdef fpc}specialize{$endif} GenDoProcVarInvoke<TProcVarTestRecSize10>(cls, {$ifdef fpc}@{$endif}ProcTestRecSize10, 10 or TTestInterfaceClass.RecSizeMarker,
  1541. [{$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(False)], [],
  1542. {$ifdef fpc}specialize{$endif} GetRecValue<TTestRecord10>(True));
  1543. finally
  1544. cls.Free;
  1545. end;
  1546. end;
  1547. begin
  1548. {$ifdef fpc}
  1549. RegisterTest(TTestInvoke);
  1550. {$else fpc}
  1551. RegisterTest(TTestInvoke.Suite);
  1552. {$endif fpc}
  1553. end.