tests.rtti.invoke.pas 99 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734
  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,
  10. {$ELSE FPC}
  11. TestFramework,
  12. {$ENDIF FPC}
  13. sysutils, typinfo, Rtti,
  14. tests.rtti.invoketypes,
  15. Tests.Rtti.Util;
  16. type
  17. TProcArgs = record
  18. aInputArgs,
  19. aOutputArgs: TValueArray;
  20. aResult: TValue;
  21. end;
  22. { TTestInvokeBase }
  23. TTestInvokeBase = class(TTestCase)
  24. private type
  25. TInvokeFlag = (
  26. ifStatic,
  27. ifConstructor
  28. );
  29. TInvokeFlags = set of TInvokeFlag;
  30. private
  31. function DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray; aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
  32. procedure DoStaticInvokeTestVariant(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: String);
  33. procedure DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
  34. procedure DoStaticInvokeTestAnsiStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
  35. procedure DoStaticInvokeTestUnicodeStringCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString);
  36. procedure DoIntfInvoke(aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  37. procedure DoMethodInvoke(aInst: TObject; aMethod: TMethod; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  38. procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs, aOutputArgs: TValueArray; aResult: TValue);overload;
  39. procedure DoProcVarInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aData : TProcArgs);overload;
  40. procedure DoProcInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aData : TProcArgs); overload;
  41. procedure DoProcInvoke(aInst: TObject; aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);overload;
  42. procedure DoUntypedInvoke(aInst: TObject; aProc: CodePointer; aMethod: TMethod; aTypeInfo: PTypeInfo; aData : TProcArgs); overload;
  43. procedure DoUntypedInvoke(aInst: TObject; aProc: CodePointer; aMethod: TMethod; aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray; aResult: TValue); overload;
  44. function GetRecValue(aTypeInfo : PTypeInfo; aSize : integer; aReverse: Boolean): TValue;
  45. end;
  46. { TTestInvoke }
  47. TTestInvoke = class(TTestInvokeBase)
  48. published
  49. procedure TestShortString;
  50. procedure TestAnsiString;
  51. procedure TestWideString;
  52. procedure TestUnicodeString;
  53. procedure TestVariant;
  54. procedure TestLongInt;
  55. procedure TestInt64;
  56. procedure TestIntfVariant;
  57. procedure TestTObject;
  58. end;
  59. { TTestInvokeIntfMethods }
  60. TTestInvokeIntfMethods = class(TTestInvokeBase)
  61. Published
  62. Procedure Test1;
  63. Procedure Test2;
  64. Procedure Test3;
  65. Procedure Test4;
  66. Procedure Test5;
  67. Procedure Test6;
  68. Procedure Test7;
  69. Procedure Test8;
  70. Procedure Test9;
  71. Procedure Test10;
  72. Procedure Test11;
  73. Procedure Test12;
  74. Procedure Test13;
  75. Procedure Test14;
  76. Procedure Test15;
  77. Procedure Test16;
  78. Procedure Test17;
  79. Procedure Test18;
  80. Procedure Test19;
  81. Procedure Test20;
  82. Procedure Test21;
  83. Procedure Test22;
  84. end;
  85. { TTestInvokeIntfMethodsRecs }
  86. TTestInvokeIntfMethodsRecs = class(TTestInvokeBase)
  87. Published
  88. Procedure Test1;
  89. Procedure Test2;
  90. Procedure Test3;
  91. Procedure Test4;
  92. Procedure Test5;
  93. Procedure Test6;
  94. Procedure Test7;
  95. Procedure Test8;
  96. Procedure Test9;
  97. Procedure Test10;
  98. end;
  99. { TTestInvokeMethodVars }
  100. TTestInvokeMethodTests = class(TTestInvokeBase)
  101. protected
  102. cls: TTestInterfaceClass;
  103. procedure DoProcVarInvoke(aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs, aOutputArgs: TValueArray; aResult: TValue); overload;
  104. procedure DoProcInvoke(aProc: CodePointer; aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs, aOutputArgs: TValueArray; aResult: TValue); overload;
  105. procedure DoUntypedInvoke(aProc: CodePointer; aMethod: TMethod; aTypeInfo: PTypeInfo; const aInputArgs, aOutputArgs: TValueArray); overload;
  106. Public
  107. Procedure SetUp; override;
  108. Procedure TearDown; override;
  109. end;
  110. TTestInvokeMethodVars = class(TTestInvokeMethodTests)
  111. Published
  112. Procedure Test1;
  113. Procedure Test2;
  114. Procedure Test3;
  115. Procedure Test4;
  116. Procedure Test5;
  117. Procedure Test6;
  118. Procedure Test7;
  119. Procedure Test8;
  120. Procedure Test9;
  121. Procedure Test10;
  122. Procedure Test11;
  123. Procedure Test12;
  124. Procedure Test13;
  125. Procedure Test14;
  126. Procedure Test15;
  127. Procedure Test16;
  128. Procedure Test17;
  129. Procedure Test18;
  130. Procedure Test19;
  131. Procedure Test20;
  132. Procedure Test21;
  133. Procedure Test22;
  134. end;
  135. { TTestInvokeMethodVarsRecs }
  136. TTestInvokeMethodVarsRecs = class(TTestInvokeMethodTests)
  137. Published
  138. Procedure Test1;
  139. Procedure Test2;
  140. Procedure Test3;
  141. Procedure Test4;
  142. Procedure Test5;
  143. Procedure Test6;
  144. Procedure Test7;
  145. Procedure Test8;
  146. Procedure Test9;
  147. Procedure Test10;
  148. end;
  149. { TTestInvokeProcVars }
  150. TTestInvokeProcVars = class(TTestInvokeMethodTests)
  151. Published
  152. Procedure Test1;
  153. Procedure Test2;
  154. Procedure Test3;
  155. Procedure Test4;
  156. Procedure Test5;
  157. Procedure Test6;
  158. Procedure Test7;
  159. Procedure Test8;
  160. Procedure Test9;
  161. Procedure Test10;
  162. Procedure Test11;
  163. Procedure Test12;
  164. Procedure Test13;
  165. Procedure Test14;
  166. Procedure Test15;
  167. Procedure Test16;
  168. Procedure Test17;
  169. Procedure Test18;
  170. Procedure Test19;
  171. Procedure Test20;
  172. Procedure Test21;
  173. Procedure Test22;
  174. end;
  175. { TTestInvokeProcVarRecs }
  176. TTestInvokeProcVarRecs = class(TTestInvokeMethodTests)
  177. Published
  178. Procedure Test1;
  179. Procedure Test2;
  180. Procedure Test3;
  181. Procedure Test4;
  182. Procedure Test5;
  183. Procedure Test6;
  184. Procedure Test7;
  185. Procedure Test8;
  186. Procedure Test9;
  187. Procedure Test10;
  188. end;
  189. { TTestInvokeTestProc }
  190. TTestInvokeTestProc = Class(TTestInvokeMethodTests)
  191. Published
  192. Procedure Test1;
  193. Procedure Test2;
  194. Procedure Test3;
  195. Procedure Test4;
  196. Procedure Test5;
  197. Procedure Test6;
  198. Procedure Test7;
  199. Procedure Test8;
  200. {$ifdef NEEDS_POINTER_HELPER}
  201. Procedure Test9;
  202. Procedure Test10;
  203. Procedure Test11;
  204. Procedure Test12;
  205. Procedure Test13;
  206. Procedure Test14;
  207. Procedure Test15;
  208. Procedure Test16;
  209. Procedure Test17;
  210. {$ENDIF}
  211. Procedure Test18;
  212. Procedure Test19;
  213. Procedure Test20;
  214. Procedure Test21;
  215. Procedure Test22;
  216. end;
  217. { TTestInvokeTestProcRecs }
  218. TTestInvokeTestProcRecs = Class(TTestInvokeMethodTests)
  219. Published
  220. Procedure Test1;
  221. Procedure Test2;
  222. Procedure Test3;
  223. Procedure Test4;
  224. Procedure Test5;
  225. Procedure Test6;
  226. Procedure Test7;
  227. Procedure Test8;
  228. Procedure Test9;
  229. Procedure Test10;
  230. end;
  231. { TTestInvokeUntyped }
  232. TTestInvokeUntyped = Class(TTestInvokeMethodTests)
  233. Published
  234. Procedure Test1;
  235. Procedure Test2;
  236. Procedure Test3;
  237. Procedure Test4;
  238. Procedure Test5;
  239. Procedure Test6;
  240. Procedure Test7;
  241. Procedure Test8;
  242. Procedure Test9;
  243. end;
  244. implementation
  245. { ----------------------------------------------------------------------
  246. Auxiliary methods to test
  247. ----------------------------------------------------------------------}
  248. procedure ProcTest1;
  249. begin
  250. TTestInterfaceClass.ProcVarInst.Test1;
  251. end;
  252. function ProcTest2: SizeInt;
  253. begin
  254. Result := TTestInterfaceClass.ProcVarInst.Test2;
  255. end;
  256. function ProcTest3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
  257. begin
  258. Result := TTestInterfaceClass.ProcVarInst.Test3(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  259. end;
  260. procedure ProcTest4(aArg1: AnsiString; aArg2: UnicodeString; aArg3: WideString; aArg4: ShortString);
  261. begin
  262. TTestInterfaceClass.ProcVarInst.Test4(aArg1, aArg2, aArg3, aArg4);
  263. end;
  264. function ProcTest5: AnsiString;
  265. begin
  266. Result := TTestInterfaceClass.ProcVarInst.Test5;
  267. end;
  268. function ProcTest6: UnicodeString;
  269. begin
  270. Result := TTestInterfaceClass.ProcVarInst.Test6;
  271. end;
  272. function ProcTest7: WideString;
  273. begin
  274. Result := TTestInterfaceClass.ProcVarInst.Test7;
  275. end;
  276. function ProcTest8: ShortString;
  277. begin
  278. Result := TTestInterfaceClass.ProcVarInst.Test8;
  279. end;
  280. procedure ProcTest9(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: SizeInt);
  281. begin
  282. TTestInterfaceClass.ProcVarInst.Test9(aArg1, aArg2, aArg3, aArg4);
  283. end;
  284. procedure ProcTest10(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: AnsiString);
  285. begin
  286. TTestInterfaceClass.ProcVarInst.Test10(aArg1, aArg2, aArg3, aArg4);
  287. end;
  288. procedure ProcTest11(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: ShortString);
  289. begin
  290. TTestInterfaceClass.ProcVarInst.Test11(aArg1, aArg2, aArg3, aArg4);
  291. end;
  292. 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);
  293. begin
  294. TTestInterfaceClass.ProcVarInst.Test12(aArg1, aArg2, aArg3, aArg4);
  295. end;
  296. function ProcTest13(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Single): Single;
  297. begin
  298. Result := TTestInterfaceClass.ProcVarInst.Test13(aArg1, aArg2, aArg3, aArg4);
  299. end;
  300. function ProcTest14(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Double): Double;
  301. begin
  302. Result := TTestInterfaceClass.ProcVarInst.Test14(aArg1, aArg2, aArg3, aArg4);
  303. end;
  304. function ProcTest15(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Extended): Extended;
  305. begin
  306. Result := TTestInterfaceClass.ProcVarInst.Test15(aArg1, aArg2, aArg3, aArg4);
  307. end;
  308. function ProcTest16(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Comp): Comp;
  309. begin
  310. Result := TTestInterfaceClass.ProcVarInst.Test16(aArg1, aArg2, aArg3, aArg4);
  311. end;
  312. function ProcTest17(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4: Currency): Currency;
  313. begin
  314. Result := TTestInterfaceClass.ProcVarInst.Test17(aArg1, aArg2, aArg3, aArg4);
  315. end;
  316. function ProcTest18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
  317. begin
  318. Result := TTestInterfaceClass.ProcVarInst.Test18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  319. end;
  320. function ProcTest19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
  321. begin
  322. Result := TTestInterfaceClass.ProcVarInst.Test19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  323. end;
  324. function ProcTest20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
  325. begin
  326. Result := TTestInterfaceClass.ProcVarInst.Test20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  327. end;
  328. function ProcTest21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
  329. begin
  330. Result := TTestInterfaceClass.ProcVarInst.Test21(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  331. end;
  332. function ProcTest22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
  333. begin
  334. Result := TTestInterfaceClass.ProcVarInst.Test22(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10);
  335. end;
  336. function ProcTestRecSize1(aArg1: TTestRecord1): TTestRecord1;
  337. begin
  338. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize1(aArg1);
  339. end;
  340. function ProcTestRecSize2(aArg1: TTestRecord2): TTestRecord2;
  341. begin
  342. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize2(aArg1);
  343. end;
  344. function ProcTestRecSize3(aArg1: TTestRecord3): TTestRecord3;
  345. begin
  346. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize3(aArg1);
  347. end;
  348. function ProcTestRecSize4(aArg1: TTestRecord4): TTestRecord4;
  349. begin
  350. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize4(aArg1);
  351. end;
  352. function ProcTestRecSize5(aArg1: TTestRecord5): TTestRecord5;
  353. begin
  354. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize5(aArg1);
  355. end;
  356. function ProcTestRecSize6(aArg1: TTestRecord6): TTestRecord6;
  357. begin
  358. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize6(aArg1);
  359. end;
  360. function ProcTestRecSize7(aArg1: TTestRecord7): TTestRecord7;
  361. begin
  362. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize7(aArg1);
  363. end;
  364. function ProcTestRecSize8(aArg1: TTestRecord8): TTestRecord8;
  365. begin
  366. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize8(aArg1);
  367. end;
  368. function ProcTestRecSize9(aArg1: TTestRecord9): TTestRecord9;
  369. begin
  370. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize9(aArg1);
  371. end;
  372. function ProcTestRecSize10(aArg1: TTestRecord10): TTestRecord10;
  373. begin
  374. Result := TTestInterfaceClass.ProcVarRecInst.TestRecSize10(aArg1);
  375. end;
  376. procedure ProcTestUntyped(var aArg1; out aArg2; const aArg3; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4);
  377. begin
  378. TTestInterfaceClass.ProcVarInst.TestUntyped(aArg1, aArg2, aArg3, aArg4);
  379. end;
  380. // Shortstring parameters
  381. function TestShortStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; register;
  382. begin
  383. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  384. end;
  385. function TestShortStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; cdecl;
  386. begin
  387. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  388. end;
  389. function TestShortStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; stdcall;
  390. begin
  391. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  392. end;
  393. function TestShortStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: ShortString): ShortString; pascal;
  394. begin
  395. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  396. end;
  397. // Ansistring parameters
  398. function TestAnsiStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; register;
  399. begin
  400. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  401. end;
  402. function TestAnsiStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; cdecl;
  403. begin
  404. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  405. end;
  406. function TestAnsiStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; stdcall;
  407. begin
  408. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  409. end;
  410. function TestAnsiStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: AnsiString): AnsiString; pascal;
  411. begin
  412. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  413. end;
  414. // Widestring parameters
  415. function TestWideStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; register;
  416. begin
  417. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  418. end;
  419. function TestWideStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; cdecl;
  420. begin
  421. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  422. end;
  423. function TestWideStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; stdcall;
  424. begin
  425. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  426. end;
  427. function TestWideStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: WideString): WideString; pascal;
  428. begin
  429. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  430. end;
  431. // Unicode parameters
  432. function TestUnicodeStringRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; register;
  433. begin
  434. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  435. end;
  436. function TestUnicodeStringCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; cdecl;
  437. begin
  438. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  439. end;
  440. function TestUnicodeStringStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; stdcall;
  441. begin
  442. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  443. end;
  444. function TestUnicodeStringPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: UnicodeString): UnicodeString; pascal;
  445. begin
  446. Result := aArg1 + aArg2 + aArg3 + aArg4 + aArg5 + aArg6;
  447. end;
  448. // Longint parameters
  449. function TestLongIntRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; register;
  450. begin
  451. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  452. end;
  453. function TestLongIntCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; cdecl;
  454. begin
  455. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  456. end;
  457. function TestLongIntStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; stdcall;
  458. begin
  459. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  460. end;
  461. function TestLongIntPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: LongInt): LongInt; pascal;
  462. begin
  463. Result := aArg1 + aArg2 * 10 + aArg3 * 100 + aArg4 * 1000 + aArg5 * 10000 + aArg6 * 100000;
  464. end;
  465. // class parameters
  466. type
  467. TTestClass = class
  468. fString: String;
  469. fValue: LongInt;
  470. end;
  471. function TestTTestClassRegister(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; register;
  472. begin
  473. Result := TTestClass.Create;
  474. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  475. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  476. end;
  477. function TestTTestClassCdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; cdecl;
  478. begin
  479. Result := TTestClass.Create;
  480. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  481. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  482. end;
  483. function TestTTestClassStdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; stdcall;
  484. begin
  485. Result := TTestClass.Create;
  486. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  487. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  488. end;
  489. function TestTTestClassPascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: TTestClass): TTestClass; pascal;
  490. begin
  491. Result := TTestClass.Create;
  492. Result.fString := aArg1.fString + aArg2.fString + aArg3.fString + aArg4.fString + aArg5.fString + aArg6.fString;
  493. Result.fValue := aArg1.fValue + aArg2.fValue * 10 + aArg3.fValue * 100 + aArg4.fValue * 1000 + aArg5.fValue * 10000 + aArg6.fValue * 100000;
  494. end;
  495. // Variant parameters
  496. function TestVariantRegister(aArg1 : variant): string; register;
  497. begin
  498. Result:=aArg1;
  499. end;
  500. function TestVariantCdecl(aArg1 : variant): string; cdecl;
  501. begin
  502. Result:=aArg1;
  503. end;
  504. function TestVariantPascal(aArg1 : variant): string; pascal;
  505. begin
  506. Result:=aArg1;
  507. end;
  508. // Int64 parameters
  509. function TestInt64Register(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; register;
  510. begin
  511. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  512. end;
  513. function TestInt64Cdecl(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; cdecl;
  514. begin
  515. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  516. end;
  517. function TestInt64StdCall(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; stdcall;
  518. begin
  519. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  520. end;
  521. function TestInt64Pascal(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6: Int64): Int64; pascal;
  522. begin
  523. Result := aArg1 + aArg2 * 100 + aArg3 * 10000 + aArg4 * 1000000 + aArg5 * 100000000 + aArg6 * 10000000000;
  524. end;
  525. { ----------------------------------------------------------------------
  526. TTestInvokeBase
  527. ----------------------------------------------------------------------}
  528. function TTestInvokeBase.DoInvoke(aCodeAddress: CodePointer; aArgs: TValueArray;
  529. aCallConv: TCallConv; aResultType: PTypeInfo; aFlags: TInvokeFlags; out aValid: Boolean): TValue;
  530. begin
  531. try
  532. Result := Rtti.Invoke(aCodeAddress, aArgs, aCallConv, aResultType, ifStatic in aFlags, ifConstructor in aFlags);
  533. aValid := True;
  534. except
  535. on e: ENotImplemented do begin
  536. Status('Ignoring unimplemented functionality of test');
  537. aValid := False;
  538. end else
  539. raise;
  540. end;
  541. end;
  542. procedure TTestInvokeBase.DoStaticInvokeTestOrdinalCompare(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: Int64);
  543. var
  544. resval: TValue;
  545. valid: Boolean;
  546. begin
  547. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  548. if valid and Assigned(aReturnType) and (resval.AsOrdinal <> aResult) then begin
  549. Fail('Result of test "%s" is unexpected; expected: %s, got: %s', [aTestName, IntToStr(aResult), IntToStr(resval.AsOrdinal)]);
  550. end;
  551. end;
  552. procedure TTestInvokeBase.DoStaticInvokeTestVariant(const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv; aValues: TValueArray; aReturnType: PTypeInfo; aResult: String);
  553. var
  554. resval: TValue;
  555. valid: Boolean;
  556. begin
  557. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  558. if valid and (resval.AsAnsiString <> aResult) then begin
  559. Fail('Result of test "%s" is unexpected; expected: %s, got: %s', [aTestName, aResult, String(resval.AsAnsiString)]);
  560. end;
  561. end;
  562. procedure TTestInvokeBase.DoStaticInvokeTestAnsiStringCompare(
  563. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  564. aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: AnsiString);
  565. var
  566. resval: TValue;
  567. valid: Boolean;
  568. begin
  569. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  570. if valid and Assigned(aReturnType) and (resval.AsAnsiString <> aResult) then begin
  571. Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
  572. end;
  573. end;
  574. procedure TTestInvokeBase.DoStaticInvokeTestUnicodeStringCompare(
  575. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  576. aValues: TValueArray; aReturnType: PTypeInfo; constref aResult: UnicodeString
  577. );
  578. var
  579. resval: TValue;
  580. valid: Boolean;
  581. begin
  582. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  583. if valid and Assigned(aReturnType) and (resval.AsUnicodeString <> aResult) then begin
  584. Fail('Result of test "%s" is unexpected; expected: "%s", got: "%s"', [aTestName, aResult, resval.AsString]);
  585. end;
  586. end;
  587. procedure TTestInvokeBase.DoIntfInvoke(aIndex: SizeInt; aInputArgs,
  588. aOutputArgs: TValueArray; aResult: TValue);
  589. var
  590. cls: TTestInterfaceClass;
  591. intf: ITestInterface;
  592. name: String;
  593. context: TRttiContext;
  594. t: TRttiType;
  595. inst, res: TValue;
  596. method: TRttiMethod;
  597. i: SizeInt;
  598. input: array of TValue;
  599. begin
  600. input:=Nil;
  601. cls := TTestInterfaceClass.Create;
  602. intf := cls;
  603. TValue.Make(@intf, TypeInfo(intf), inst);
  604. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
  605. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
  606. else
  607. name := 'Test' + IntToStr(aIndex);
  608. context := TRttiContext.Create;
  609. try
  610. t := context.GetType(TypeInfo(ITestInterface));
  611. method := t.GetMethod(name);
  612. Check(Assigned(method), 'Method not found: ' + name);
  613. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  614. IValueData of managed types) }
  615. SetLength(input, Length(aInputArgs));
  616. for i := 0 to High(input) do
  617. input[i] := CopyValue(aInputArgs[i]);
  618. try
  619. res := method.Invoke(inst, aInputArgs);
  620. except
  621. DumpExceptionBacktrace(output);
  622. raise;
  623. end;
  624. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  625. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  626. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  627. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  628. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  629. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  630. for i := 0 to High(aInputArgs) do begin
  631. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  632. end;
  633. for i := 0 to High(aOutputArgs) do begin
  634. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  635. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  636. end;
  637. finally
  638. context.Free;
  639. end;
  640. end;
  641. procedure TTestInvokeBase.DoMethodInvoke(aInst: TObject; aMethod: TMethod;
  642. aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  643. var
  644. cls: TTestInterfaceClass;
  645. name: String;
  646. context: TRttiContext;
  647. t: TRttiType;
  648. callable, res: TValue;
  649. method: TRttiMethodType;
  650. i: SizeInt;
  651. input: array of TValue;
  652. begin
  653. input:=Nil;
  654. cls := aInst as TTestInterfaceClass;
  655. cls.Reset;
  656. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then
  657. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker)
  658. else
  659. name := 'Test' + IntToStr(aIndex);
  660. TValue.Make(@aMethod, aTypeInfo, callable);
  661. context := TRttiContext.Create;
  662. try
  663. t := context.GetType(aTypeInfo);
  664. Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name);
  665. method := t as TRttiMethodType;
  666. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  667. IValueData of managed types) }
  668. SetLength(input, Length(aInputArgs));
  669. for i := 0 to High(input) do
  670. input[i] := CopyValue(aInputArgs[i]);
  671. res := method.Invoke(callable, aInputArgs);
  672. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  673. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  674. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  675. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  676. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  677. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  678. for i := 0 to High(aInputArgs) do begin
  679. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  680. end;
  681. for i := 0 to High(aOutputArgs) do begin
  682. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  683. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  684. end;
  685. finally
  686. context.Free;
  687. end;
  688. end;
  689. procedure TTestInvokeBase.DoProcVarInvoke(aInst: TObject; aProc: CodePointer;
  690. aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs, aOutputArgs: TValueArray; aResult: TValue);
  691. var
  692. cls: TTestInterfaceClass;
  693. name: String;
  694. context: TRttiContext;
  695. t: TRttiType;
  696. callable, res: TValue;
  697. proc: TRttiProcedureType;
  698. i: SizeInt;
  699. input: array of TValue;
  700. begin
  701. input:=Nil;
  702. cls := aInst as TTestInterfaceClass;
  703. cls.Reset;
  704. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
  705. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
  706. TTestInterfaceClass.ProcVarRecInst := cls;
  707. end else begin
  708. name := 'Test' + IntToStr(aIndex);
  709. TTestInterfaceClass.ProcVarInst := cls;
  710. end;
  711. TValue.Make(@aProc, aTypeInfo, callable);
  712. context := TRttiContext.Create;
  713. try
  714. t := context.GetType(aTypeInfo);
  715. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  716. proc := t as TRttiProcedureType;
  717. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  718. IValueData of managed types) }
  719. SetLength(input, Length(aInputArgs));
  720. for i := 0 to High(input) do
  721. input[i] := CopyValue(aInputArgs[i]);
  722. res := proc.Invoke(callable, aInputArgs);
  723. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  724. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  725. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  726. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  727. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  728. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  729. for i := 0 to High(aInputArgs) do begin
  730. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  731. end;
  732. for i := 0 to High(aOutputArgs) do begin
  733. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  734. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  735. end;
  736. finally
  737. context.Free;
  738. end;
  739. end;
  740. procedure TTestInvokeBase.DoProcVarInvoke(aInst: TObject; aProc: CodePointer;
  741. aTypeInfo: PTypeInfo; aIndex: SizeInt; aData: TProcArgs);
  742. var
  743. cls: TTestInterfaceClass;
  744. name: String;
  745. context: TRttiContext;
  746. t: TRttiType;
  747. callable, res: TValue;
  748. proc: TRttiProcedureType;
  749. i: SizeInt;
  750. input: array of TValue;
  751. begin
  752. input:=Nil;
  753. cls := aInst as TTestInterfaceClass;
  754. cls.Reset;
  755. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
  756. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
  757. TTestInterfaceClass.ProcVarRecInst := cls;
  758. end else begin
  759. name := 'Test' + IntToStr(aIndex);
  760. TTestInterfaceClass.ProcVarInst := cls;
  761. end;
  762. TValue.Make(@aProc, aTypeInfo, callable);
  763. context := TRttiContext.Create;
  764. try
  765. t := context.GetType(aTypeInfo);
  766. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  767. proc := t as TRttiProcedureType;
  768. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  769. IValueData of managed types) }
  770. SetLength(input, Length(aData.aInputArgs));
  771. for i := 0 to High(input) do
  772. input[i] := CopyValue(aData.aInputArgs[i]);
  773. res := proc.Invoke(callable, aData.aInputArgs);
  774. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  775. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  776. Check(EqualValues(aData.aResult, res), 'Expected result value differs from returned for ' + name);
  777. CheckEquals(Length(aData.aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  778. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  779. CheckEquals(Length(aData.aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  780. for i := 0 to High(aData.aInputArgs) do begin
  781. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  782. end;
  783. for i := 0 to High(aData.aOutputArgs) do begin
  784. Check(EqualValues(aData.aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  785. Check(EqualValues(aData.aOutputArgs[i], aData.aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  786. end;
  787. finally
  788. context.Free;
  789. end;
  790. end;
  791. procedure TTestInvokeBase.DoProcInvoke(aInst: TObject; aProc: CodePointer;
  792. aTypeInfo: PTypeInfo; aIndex: SizeInt; aInputArgs, aOutputArgs: TValueArray;
  793. aResult: TValue);
  794. var
  795. cls: TTestInterfaceClass;
  796. name: String;
  797. context: TRttiContext;
  798. t: TRttiType;
  799. callable, res: TValue;
  800. proc: TRttiProcedureType;
  801. i: SizeInt;
  802. input: array of TValue;
  803. restype: PTypeInfo;
  804. begin
  805. input:=Nil;
  806. cls := aInst as TTestInterfaceClass;
  807. cls.Reset;
  808. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
  809. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
  810. TTestInterfaceClass.ProcVarRecInst := cls;
  811. end else begin
  812. name := 'Test' + IntToStr(aIndex);
  813. TTestInterfaceClass.ProcVarInst := cls;
  814. end;
  815. TValue.Make(@aProc, aTypeInfo, callable);
  816. context := TRttiContext.Create;
  817. try
  818. t := context.GetType(aTypeInfo);
  819. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  820. proc := t as TRttiProcedureType;
  821. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  822. IValueData of managed types) }
  823. SetLength(input, Length(aInputArgs));
  824. for i := 0 to High(input) do
  825. input[i] := CopyValue(aInputArgs[i]);
  826. if Assigned(proc.ReturnType) then
  827. restype := PTypeInfo(proc.ReturnType.Handle)
  828. else
  829. restype := Nil;
  830. res := Rtti.Invoke(aProc, aInputArgs, proc.CallingConvention, restype, True, False);
  831. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  832. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  833. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  834. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  835. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  836. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  837. for i := 0 to High(aInputArgs) do begin
  838. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  839. end;
  840. for i := 0 to High(aOutputArgs) do begin
  841. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  842. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  843. end;
  844. finally
  845. context.Free;
  846. end;
  847. end;
  848. procedure TTestInvokeBase.DoProcInvoke(aInst: TObject; aProc: CodePointer;
  849. aTypeInfo: PTypeInfo; aIndex: SizeInt; aData : TProcArgs);
  850. var
  851. cls: TTestInterfaceClass;
  852. name: String;
  853. context: TRttiContext;
  854. t: TRttiType;
  855. callable, res: TValue;
  856. proc: TRttiProcedureType;
  857. i: SizeInt;
  858. input: array of TValue;
  859. restype: PTypeInfo;
  860. begin
  861. input:=Nil;
  862. cls := aInst as TTestInterfaceClass;
  863. cls.Reset;
  864. if aIndex and TTestInterfaceClass.RecSizeMarker <> 0 then begin
  865. name := 'TestRecSize' + IntToStr(aIndex and not TTestInterfaceClass.RecSizeMarker);
  866. TTestInterfaceClass.ProcVarRecInst := cls;
  867. end else begin
  868. name := 'Test' + IntToStr(aIndex);
  869. TTestInterfaceClass.ProcVarInst := cls;
  870. end;
  871. TValue.Make(@aProc, aTypeInfo, callable);
  872. context := TRttiContext.Create;
  873. try
  874. t := context.GetType(aTypeInfo);
  875. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  876. proc := t as TRttiProcedureType;
  877. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  878. IValueData of managed types) }
  879. SetLength(input, Length(aData.aInputArgs));
  880. for i := 0 to High(input) do
  881. input[i] := CopyValue(aData.aInputArgs[i]);
  882. if Assigned(proc.ReturnType) then
  883. restype := PTypeInfo(proc.ReturnType.Handle)
  884. else
  885. restype := Nil;
  886. res := Rtti.Invoke(aProc, aData.aInputArgs, proc.CallingConvention, restype, True, False);
  887. CheckEquals(aIndex, cls.CalledMethod, 'Wrong method called for ' + name);
  888. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  889. Check(EqualValues(aData.aResult, res), 'Expected result value differs from returned for ' + name);
  890. CheckEquals(Length(aData.aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  891. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  892. CheckEquals(Length(aData.aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  893. for i := 0 to High(aData.aInputArgs) do begin
  894. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  895. end;
  896. for i := 0 to High(aData.aOutputArgs) do begin
  897. Check(EqualValues(aData.aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  898. Check(EqualValues(aData.aOutputArgs[i], aData.aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  899. end;
  900. finally
  901. context.Free;
  902. end;
  903. end;
  904. procedure TTestInvokeBase.DoUntypedInvoke(aInst: TObject; aProc: CodePointer;
  905. aMethod: TMethod; aTypeInfo: PTypeInfo; aInputArgs, aOutputArgs: TValueArray;
  906. aResult: TValue);
  907. var
  908. cls: TTestInterfaceClass;
  909. intf: ITestInterface;
  910. name: String;
  911. context: TRttiContext;
  912. t: TRttiType;
  913. callable, res: TValue;
  914. proc: TRttiInvokableType;
  915. method: TRttiMethod;
  916. i: SizeInt;
  917. input: array of TValue;
  918. begin
  919. input:=Nil;
  920. cls := aInst as TTestInterfaceClass;
  921. cls.Reset;
  922. name := 'TestUntyped';
  923. TTestInterfaceClass.ProcVarInst := cls;
  924. context := TRttiContext.Create;
  925. try
  926. method := Nil;
  927. proc := Nil;
  928. if Assigned(aProc) then begin
  929. TValue.Make(@aProc, aTypeInfo, callable);
  930. t := context.GetType(aTypeInfo);
  931. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  932. proc := t as TRttiProcedureType;
  933. end else if Assigned(aMethod.Code) then begin
  934. TValue.Make(@aMethod, aTypeInfo, callable);
  935. t := context.GetType(aTypeInfo);
  936. Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name);
  937. proc := t as TRttiMethodType;
  938. end else begin
  939. intf := cls;
  940. TValue.Make(@intf, TypeInfo(intf), callable);
  941. t := context.GetType(TypeInfo(ITestInterface));
  942. method := t.GetMethod(name);
  943. Check(Assigned(method), 'Method not found: ' + name);
  944. end;
  945. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  946. IValueData of managed types) }
  947. SetLength(input, Length(aInputArgs));
  948. SetLength(cls.ExpectedArgs, Length(aInputArgs));
  949. for i := 0 to High(input) do begin
  950. input[i] := CopyValue(aInputArgs[i]);
  951. cls.ExpectedArgs[i] := CopyValue(aInputArgs[i]);
  952. end;
  953. SetLength(cls.OutArgs, Length(aOutputArgs));
  954. for i := 0 to High(cls.OutArgs) do begin
  955. cls.OutArgs[i] := CopyValue(aOutputArgs[i]);
  956. end;
  957. if Assigned(proc) then
  958. res := proc.Invoke(callable, aInputArgs)
  959. else
  960. res := method.Invoke(callable, aInputArgs);
  961. CheckEquals(-1, cls.CalledMethod, 'Wrong method called for ' + name);
  962. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  963. Check(EqualValues(aResult, res), 'Expected result value differs from returned for ' + name);
  964. CheckEquals(Length(aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  965. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  966. CheckEquals(Length(aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  967. for i := 0 to High(aInputArgs) do begin
  968. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  969. end;
  970. for i := 0 to High(aOutputArgs) do begin
  971. Check(EqualValues(aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  972. Check(EqualValues(aOutputArgs[i], aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  973. end;
  974. finally
  975. context.Free;
  976. end;
  977. end;
  978. procedure TTestInvokeBase.DoUntypedInvoke(aInst: TObject; aProc: CodePointer;
  979. aMethod: TMethod; aTypeInfo: PTypeInfo; aData : TProcArgs);
  980. var
  981. cls: TTestInterfaceClass;
  982. intf: ITestInterface;
  983. name: String;
  984. context: TRttiContext;
  985. t: TRttiType;
  986. callable, res: TValue;
  987. proc: TRttiInvokableType;
  988. method: TRttiMethod;
  989. i: SizeInt;
  990. input: array of TValue;
  991. begin
  992. input:=Nil;
  993. cls := aInst as TTestInterfaceClass;
  994. cls.Reset;
  995. name := 'TestUntyped';
  996. TTestInterfaceClass.ProcVarInst := cls;
  997. context := TRttiContext.Create;
  998. try
  999. method := Nil;
  1000. proc := Nil;
  1001. if Assigned(aProc) then begin
  1002. TValue.Make(@aProc, aTypeInfo, callable);
  1003. t := context.GetType(aTypeInfo);
  1004. Check(t is TRttiProcedureType, 'Not a procedure variable: ' + aTypeInfo^.Name);
  1005. proc := t as TRttiProcedureType;
  1006. end else if Assigned(aMethod.Code) then begin
  1007. TValue.Make(@aMethod, aTypeInfo, callable);
  1008. t := context.GetType(aTypeInfo);
  1009. Check(t is TRttiMethodType, 'Not a method variable: ' + aTypeInfo^.Name);
  1010. proc := t as TRttiMethodType;
  1011. end else begin
  1012. intf := cls;
  1013. TValue.Make(@intf, TypeInfo(intf), callable);
  1014. t := context.GetType(TypeInfo(ITestInterface));
  1015. method := t.GetMethod(name);
  1016. Check(Assigned(method), 'Method not found: ' + name);
  1017. end;
  1018. { arguments might be modified by Invoke (Note: Copy() does not uniquify the
  1019. IValueData of managed types) }
  1020. SetLength(input, Length(aData.aInputArgs));
  1021. SetLength(cls.ExpectedArgs, Length(aData.aInputArgs));
  1022. for i := 0 to High(input) do begin
  1023. input[i] := CopyValue(aData.aInputArgs[i]);
  1024. cls.ExpectedArgs[i] := CopyValue(aData.aInputArgs[i]);
  1025. end;
  1026. SetLength(cls.OutArgs, Length(aData.aOutputArgs));
  1027. for i := 0 to High(cls.OutArgs) do begin
  1028. cls.OutArgs[i] := CopyValue(aData.aOutputArgs[i]);
  1029. end;
  1030. if Assigned(proc) then
  1031. res := proc.Invoke(callable, aData.aInputArgs)
  1032. else
  1033. res := method.Invoke(callable, aData.aInputArgs);
  1034. CheckEquals(-1, cls.CalledMethod, 'Wrong method called for ' + name);
  1035. Check(EqualValues(cls.ResultValue, res), 'Reported result value differs from returned for ' + name);
  1036. Check(EqualValues(aData.aResult, res), 'Expected result value differs from returned for ' + name);
  1037. CheckEquals(Length(aData.aInputArgs), Length(cls.InputArgs), 'Count of input args differs for ' + name);
  1038. CheckEquals(Length(cls.OutputArgs), Length(cls.InOutMapping), 'Count of output args and in-out-mapping differs for ' + name);
  1039. CheckEquals(Length(aData.aOutputArgs), Length(cls.OutputArgs), 'Count of output args differs for ' + name);
  1040. for i := 0 to High(aData.aInputArgs) do begin
  1041. Check(EqualValues(input[i], cls.InputArgs[i]), Format('Input argument %d differs for %s', [i + 1, name]));
  1042. end;
  1043. for i := 0 to High(aData.aOutputArgs) do begin
  1044. Check(EqualValues(aData.aOutputArgs[i], cls.OutputArgs[i]), Format('Output argument %d differs for %s', [i + 1, name]));
  1045. Check(EqualValues(aData.aOutputArgs[i], aData.aInputArgs[cls.InOutMapping[i]]), Format('New output argument %d differs from expected output for %s', [i + 1, name]));
  1046. end;
  1047. finally
  1048. context.Free;
  1049. end;
  1050. end;
  1051. function TTestInvokeBase.GetRecValue(aTypeInfo: PTypeInfo; aSize: integer;
  1052. aReverse: Boolean): TValue;
  1053. var
  1054. i: LongInt;
  1055. arr: array of Byte;
  1056. begin
  1057. Arr:=nil;
  1058. SetLength(arr, aSize);
  1059. RandSeed := $54827982;
  1060. if not aReverse then begin
  1061. for i := 0 to High(arr) do
  1062. arr[i] := Random($ff);
  1063. end else begin
  1064. for i := High(arr) downto 0 do
  1065. arr[i] := Random($ff);
  1066. end;
  1067. TValue.Make(@arr[0], aTypeInfo, Result);
  1068. end;
  1069. { ----------------------------------------------------------------------
  1070. TTestInvoke
  1071. ----------------------------------------------------------------------}
  1072. procedure TTestInvoke.TestShortString;
  1073. const
  1074. strs: array[0..5] of ShortString = (
  1075. 'This ',
  1076. 'is a ',
  1077. 'test ',
  1078. 'of ',
  1079. 'shortstring ',
  1080. 'concatenation'
  1081. );
  1082. var
  1083. values: TValueArray;
  1084. resstr: ShortString;
  1085. i: LongInt;
  1086. begin
  1087. values:=Nil;
  1088. SetLength(values, Length(strs));
  1089. resstr := '';
  1090. for i := Low(values) to High(values) do begin
  1091. TValue.Make(@strs[i], TypeInfo(ShortString), values[i]);
  1092. resstr := resstr + strs[i];
  1093. end;
  1094. DoStaticInvokeTestAnsiStringCompare('ShortString Register', @TestShortStringRegister, ccReg, values, TypeInfo(ShortString), resstr);
  1095. DoStaticInvokeTestAnsiStringCompare('ShortString Cdecl', @TestShortStringCdecl, ccCdecl, values, TypeInfo(ShortString), resstr);
  1096. DoStaticInvokeTestAnsiStringCompare('ShortString StdCall', @TestShortStringStdCall, ccStdCall, values, TypeInfo(ShortString), resstr);
  1097. DoStaticInvokeTestAnsiStringCompare('ShortString Pascal', @TestShortStringPascal, ccPascal, values, TypeInfo(ShortString), resstr);
  1098. end;
  1099. procedure TTestInvoke.TestAnsiString;
  1100. const
  1101. strs: array[0..5] of AnsiString = (
  1102. 'This ',
  1103. 'is a ',
  1104. 'test ',
  1105. 'of ',
  1106. 'AnsiString ',
  1107. 'concatenation'
  1108. );
  1109. var
  1110. values: TValueArray;
  1111. resstr: AnsiString;
  1112. i: LongInt;
  1113. begin
  1114. values:=nil;
  1115. SetLength(values, Length(strs));
  1116. resstr := '';
  1117. for i := Low(values) to High(values) do begin
  1118. TValue.Make(@strs[i], TypeInfo(AnsiString), values[i]);
  1119. resstr := resstr + strs[i];
  1120. end;
  1121. DoStaticInvokeTestAnsiStringCompare('AnsiString Register', @TestAnsiStringRegister, ccReg, values, TypeInfo(AnsiString), resstr);
  1122. DoStaticInvokeTestAnsiStringCompare('AnsiString Cdecl', @TestAnsiStringCdecl, ccCdecl, values, TypeInfo(AnsiString), resstr);
  1123. DoStaticInvokeTestAnsiStringCompare('AnsiString StdCall', @TestAnsiStringStdCall, ccStdCall, values, TypeInfo(AnsiString), resstr);
  1124. DoStaticInvokeTestAnsiStringCompare('AnsiString Pascal', @TestAnsiStringPascal, ccPascal, values, TypeInfo(AnsiString), resstr);
  1125. end;
  1126. procedure TTestInvoke.TestWideString;
  1127. const
  1128. strs: array[0..5] of WideString = (
  1129. 'This ',
  1130. 'is a ',
  1131. 'test ',
  1132. 'of ',
  1133. 'WideString ',
  1134. 'concatenation'
  1135. );
  1136. var
  1137. values: TValueArray;
  1138. resstr: WideString;
  1139. i: LongInt;
  1140. begin
  1141. values:=nil;
  1142. SetLength(values, Length(strs));
  1143. resstr := '';
  1144. for i := Low(values) to High(values) do begin
  1145. TValue.Make(@strs[i], TypeInfo(WideString), values[i]);
  1146. resstr := resstr + strs[i];
  1147. end;
  1148. DoStaticInvokeTestUnicodeStringCompare('WideString Register', @TestWideStringRegister, ccReg, values, TypeInfo(WideString), resstr);
  1149. DoStaticInvokeTestUnicodeStringCompare('WideString Cdecl', @TestWideStringCdecl, ccCdecl, values, TypeInfo(WideString), resstr);
  1150. DoStaticInvokeTestUnicodeStringCompare('WideString StdCall', @TestWideStringStdCall, ccStdCall, values, TypeInfo(WideString), resstr);
  1151. DoStaticInvokeTestUnicodeStringCompare('WideString Pascal', @TestWideStringPascal, ccPascal, values, TypeInfo(WideString), resstr);
  1152. end;
  1153. procedure TTestInvoke.TestUnicodeString;
  1154. const
  1155. strs: array[0..5] of UnicodeString = (
  1156. 'This ',
  1157. 'is a ',
  1158. 'test ',
  1159. 'of ',
  1160. 'UnicodeString ',
  1161. 'concatenation'
  1162. );
  1163. var
  1164. values: TValueArray;
  1165. resstr: UnicodeString;
  1166. i: LongInt;
  1167. begin
  1168. values:=nil;
  1169. SetLength(values, Length(strs));
  1170. resstr := '';
  1171. for i := Low(values) to High(values) do begin
  1172. TValue.Make(@strs[i], TypeInfo(UnicodeString), values[i]);
  1173. resstr := resstr + strs[i];
  1174. end;
  1175. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Register', @TestUnicodeStringRegister, ccReg, values, TypeInfo(UnicodeString), resstr);
  1176. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Cdecl', @TestUnicodeStringCdecl, ccCdecl, values, TypeInfo(UnicodeString), resstr);
  1177. DoStaticInvokeTestUnicodeStringCompare('UnicodeString StdCall', @TestUnicodeStringStdCall, ccStdCall, values, TypeInfo(UnicodeString), resstr);
  1178. DoStaticInvokeTestUnicodeStringCompare('UnicodeString Pascal', @TestUnicodeStringPascal, ccPascal, values, TypeInfo(UnicodeString), resstr);
  1179. end;
  1180. procedure TTestInvoke.TestLongInt;
  1181. const
  1182. vals: array[0..5] of LongInt = (
  1183. 8,
  1184. 4,
  1185. 7,
  1186. 3,
  1187. 6,
  1188. 1
  1189. );
  1190. var
  1191. values: TValueArray;
  1192. resval, factor: LongInt;
  1193. i: LongInt;
  1194. begin
  1195. values:=nil;
  1196. SetLength(values, Length(vals));
  1197. resval := 0;
  1198. factor := 1;
  1199. for i := Low(values) to High(values) do begin
  1200. TValue.Make(@vals[i], TypeInfo(LongInt), values[i]);
  1201. resval := resval + vals[i] * factor;
  1202. factor := factor * 10;
  1203. end;
  1204. DoStaticInvokeTestOrdinalCompare('LongInt Register', @TestLongIntRegister, ccReg, values, TypeInfo(LongInt), resval);
  1205. DoStaticInvokeTestOrdinalCompare('LongInt Cdecl', @TestLongIntCdecl, ccCdecl, values, TypeInfo(LongInt), resval);
  1206. DoStaticInvokeTestOrdinalCompare('LongInt StdCall', @TestLongIntStdCall, ccStdCall, values, TypeInfo(LongInt), resval);
  1207. DoStaticInvokeTestOrdinalCompare('LongInt Pascal', @TestLongIntPascal, ccPascal, values, TypeInfo(LongInt), resval);
  1208. end;
  1209. procedure TTestInvoke.TestInt64;
  1210. const
  1211. vals: array[0..5] of Int64 = (
  1212. 8,
  1213. 4,
  1214. 7,
  1215. 3,
  1216. 6,
  1217. 1
  1218. );
  1219. var
  1220. values: TValueArray;
  1221. resval, factor: Int64;
  1222. i: LongInt;
  1223. begin
  1224. values:=nil;
  1225. SetLength(values, Length(vals));
  1226. resval := 0;
  1227. factor := 1;
  1228. for i := Low(values) to High(values) do begin
  1229. TValue.Make(@vals[i], TypeInfo(Int64), values[i]);
  1230. resval := resval + vals[i] * factor;
  1231. factor := factor * 100;
  1232. end;
  1233. DoStaticInvokeTestOrdinalCompare('Int64 Register', @TestInt64Register, ccReg, values, TypeInfo(Int64), resval);
  1234. DoStaticInvokeTestOrdinalCompare('Int64 Cdecl', @TestInt64Cdecl, ccCdecl, values, TypeInfo(Int64), resval);
  1235. DoStaticInvokeTestOrdinalCompare('Int64 StdCall', @TestInt64StdCall, ccStdCall, values, TypeInfo(Int64), resval);
  1236. DoStaticInvokeTestOrdinalCompare('Int64 Pascal', @TestInt64Pascal, ccPascal, values, TypeInfo(Int64), resval);
  1237. end;
  1238. procedure TTestInvoke.TestVariant;
  1239. var
  1240. values: TValueArray;
  1241. aValue : variant;
  1242. S : AnsiString;
  1243. begin
  1244. Values:=[];
  1245. SetLength(Values,1);
  1246. S:='A nice string';
  1247. aValue:=S;
  1248. TValue.Make(@aValue, TypeInfo(Variant), Values[0]);
  1249. DoStaticInvokeTestVariant('Test register',@TestVariantRegister,ccReg,values,TypeInfo(AnsiString),S);
  1250. DoStaticInvokeTestVariant('Test cdecl',@TestVariantCdecl,ccCdecl,values,TypeInfo(AnsiString),S);
  1251. DoStaticInvokeTestVariant('Test pascal',@TestVariantPascal,ccCdecl,values,TypeInfo(AnsiString),S);
  1252. end;
  1253. procedure TTestInvoke.TestIntfVariant;
  1254. var
  1255. values,aOutput: TValueArray;
  1256. aValue : variant;
  1257. aResult : TValue;
  1258. S : AnsiString;
  1259. begin
  1260. Values:=[];
  1261. SetLength(Values,1);
  1262. S:='A nice string';
  1263. UniqueString(S);
  1264. aValue:=S;
  1265. aResult:=Default(TValue);
  1266. TValue.Make(@S, TypeInfo(AnsiString), aResult);
  1267. TValue.Make(@aValue, TypeInfo(Variant), Values[0]);
  1268. DoIntfInvoke(23,Values,aOutput,aResult);
  1269. end;
  1270. procedure TTestInvoke.TestTObject;
  1271. procedure DoStaticInvokeTestClassCompare(
  1272. const aTestName: String; aAddress: CodePointer; aCallConv: TCallConv;
  1273. aValues: TValueArray; aReturnType: PTypeInfo; aResult: TTestClass
  1274. );
  1275. var
  1276. resval: TValue;
  1277. rescls: TTestClass;
  1278. valid: Boolean;
  1279. begin
  1280. resval := DoInvoke(aAddress, aValues, aCallConv, aReturnType, [ifStatic], valid);
  1281. if valid and Assigned(aReturnType) then begin
  1282. rescls := TTestClass(PPointer(resval.GetReferenceToRawData)^);
  1283. if (rescls.fString <> aResult.fString) or (rescls.fValue <> aResult.fValue) then
  1284. Fail('Result of test "%s" is unexpected; expected: "%s"/%s, got: "%s"/%s', [aTestName, aResult.fString, IntToStr(aResult.fValue), rescls.fString, IntToStr(rescls.fValue)]);
  1285. end;
  1286. end;
  1287. const
  1288. strs: array[0..5] of AnsiString = (
  1289. 'This ',
  1290. 'is a ',
  1291. 'test ',
  1292. 'of ',
  1293. 'AnsiString ',
  1294. 'concatenation'
  1295. );
  1296. vals: array[0..5] of Int64 = (
  1297. 8,
  1298. 4,
  1299. 7,
  1300. 3,
  1301. 6,
  1302. 1
  1303. );
  1304. var
  1305. values: TValueArray;
  1306. t, rescls: TTestClass;
  1307. i, factor: LongInt;
  1308. begin
  1309. values:=nil;
  1310. SetLength(values, Length(vals));
  1311. factor := 1;
  1312. rescls := TTestClass.Create;
  1313. for i := Low(values) to High(values) do begin
  1314. t := TTestClass.Create;
  1315. t.fString := strs[i];
  1316. t.fValue := vals[i];
  1317. TValue.Make(@t, TypeInfo(TTestClass), values[i]);
  1318. rescls.fValue := rescls.fValue + vals[i] * factor;
  1319. rescls.fString := rescls.fString + strs[i];
  1320. factor := factor * 10;
  1321. end;
  1322. DoStaticInvokeTestClassCompare('TTestClass Register', @TestTTestClassRegister, ccReg, values, TypeInfo(TTestClass), rescls);
  1323. DoStaticInvokeTestClassCompare('TTestClass Cdecl', @TestTTestClassCdecl, ccCdecl, values, TypeInfo(TTestClass), rescls);
  1324. DoStaticInvokeTestClassCompare('TTestClass StdCall', @TestTTestClassStdCall, ccStdCall, values, TypeInfo(TTestClass), rescls);
  1325. DoStaticInvokeTestClassCompare('TTestClass Pascal', @TestTTestClassPascal, ccPascal, values, TypeInfo(TTestClass), rescls);
  1326. end;
  1327. { ----------------------------------------------------------------------
  1328. TTestInvokeMethodTests
  1329. ----------------------------------------------------------------------}
  1330. procedure TTestInvokeMethodTests.DoProcVarInvoke(aProc: CodePointer;
  1331. aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs,
  1332. aOutputArgs: TValueArray; aResult: TValue);
  1333. begin
  1334. CheckNotNull(Cls,'Have class');
  1335. DoProcVarInvoke(cls,aProc,aTypeInfo,aIndex,aInputArgs,aOutputArgs,aResult);
  1336. end;
  1337. procedure TTestInvokeMethodTests.DoProcInvoke(aProc: CodePointer;
  1338. aTypeInfo: PTypeInfo; aIndex: SizeInt; const aInputArgs,
  1339. aOutputArgs: TValueArray; aResult: TValue);
  1340. begin
  1341. CheckNotNull(Cls,'Have class');
  1342. DoProcVarInvoke(cls,aProc,aTypeInfo,aIndex,aInputArgs,aOutputArgs,aResult);
  1343. end;
  1344. procedure TTestInvokeMethodTests.DoUntypedInvoke(aProc: CodePointer;
  1345. aMethod: TMethod; aTypeInfo: PTypeInfo; const aInputArgs,
  1346. aOutputArgs: TValueArray);
  1347. begin
  1348. CheckNotNull(Cls,'Have class');
  1349. DoUntypedInvoke(cls,aProc,aMethod,aTypeInfo,aInputArgs,aOutputArgs,TValue.Empty);
  1350. end;
  1351. procedure TTestInvokeMethodTests.SetUp;
  1352. begin
  1353. inherited SetUp;
  1354. cls := TTestInterfaceClass.Create;
  1355. cls.DoAddRef;
  1356. end;
  1357. procedure TTestInvokeMethodTests.TearDown;
  1358. begin
  1359. cls.DoRelease;
  1360. inherited TearDown;
  1361. end;
  1362. { ----------------------------------------------------------------------
  1363. TTestInvokeIntfMethods
  1364. ----------------------------------------------------------------------}
  1365. procedure TTestInvokeIntfMethods.Test1;
  1366. begin
  1367. DoIntfInvoke(1, [], [], TValue.Empty);
  1368. end;
  1369. procedure TTestInvokeIntfMethods.Test2;
  1370. begin
  1371. DoIntfInvoke(2, [], [], GetIntValue(42));
  1372. end;
  1373. procedure TTestInvokeIntfMethods.Test3;
  1374. begin
  1375. DoIntfInvoke(3, [
  1376. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1377. ], [], GetIntValue(42));
  1378. end;
  1379. procedure TTestInvokeIntfMethods.Test4;
  1380. begin
  1381. DoIntfInvoke(4, [
  1382. GetAnsiString('Alpha'),
  1383. GetUnicodeString('Beta'),
  1384. GetWideString('Gamma'),
  1385. GetShortString('Delta')
  1386. ], [], TValue.Empty);
  1387. end;
  1388. procedure TTestInvokeIntfMethods.Test5;
  1389. begin
  1390. DoIntfInvoke(5, [], [], GetAnsiString('Hello World'));
  1391. end;
  1392. procedure TTestInvokeIntfMethods.Test6;
  1393. begin
  1394. DoIntfInvoke(6, [], [], GetUnicodeString('Hello World'));
  1395. end;
  1396. procedure TTestInvokeIntfMethods.Test7;
  1397. begin
  1398. DoIntfInvoke(7, [], [], GetWideString('Hello World'));
  1399. end;
  1400. procedure TTestInvokeIntfMethods.Test8;
  1401. begin
  1402. DoIntfInvoke(8, [], [], GetShortString('Hello World'));
  1403. end;
  1404. procedure TTestInvokeIntfMethods.Test9;
  1405. begin
  1406. DoIntfInvoke(9, [
  1407. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1408. ], [
  1409. GetIntValue($1234), GetIntValue($5678)
  1410. ], TValue.Empty);
  1411. end;
  1412. procedure TTestInvokeIntfMethods.Test10;
  1413. begin
  1414. DoIntfInvoke(10, [
  1415. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1416. ], [
  1417. GetAnsiString('Foo'), GetAnsiString('Bar')
  1418. ], TValue.Empty);
  1419. end;
  1420. procedure TTestInvokeIntfMethods.Test11;
  1421. begin
  1422. DoIntfInvoke(11, [
  1423. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1424. ], [
  1425. GetShortString('Foo'), GetShortString('Bar')
  1426. ], TValue.Empty);
  1427. end;
  1428. procedure TTestInvokeIntfMethods.Test12;
  1429. begin
  1430. {$ifdef fpc}
  1431. DoIntfInvoke(12, [
  1432. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1433. ], [
  1434. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1435. ], TValue.Empty);
  1436. {$endif}
  1437. end;
  1438. procedure TTestInvokeIntfMethods.Test13;
  1439. begin
  1440. DoIntfInvoke(13, [
  1441. GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
  1442. ], [
  1443. GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
  1444. ], GetSingleValue(SingleRes));
  1445. end;
  1446. procedure TTestInvokeIntfMethods.Test14;
  1447. begin
  1448. DoIntfInvoke(14, [
  1449. GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
  1450. ], [
  1451. GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
  1452. ], GetDoubleValue(DoubleRes));
  1453. end;
  1454. procedure TTestInvokeIntfMethods.Test15;
  1455. begin
  1456. DoIntfInvoke(15, [
  1457. GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
  1458. ], [
  1459. GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
  1460. ], GetExtendedValue(ExtendedRes));
  1461. end;
  1462. procedure TTestInvokeIntfMethods.Test16;
  1463. begin
  1464. DoIntfInvoke(16, [
  1465. GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
  1466. ], [
  1467. GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
  1468. ], GetCompValue(CompRes));
  1469. end;
  1470. procedure TTestInvokeIntfMethods.Test17;
  1471. begin
  1472. DoIntfInvoke(17, [
  1473. GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
  1474. ], [
  1475. GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
  1476. ], GetCurrencyValue(CurrencyRes));
  1477. end;
  1478. procedure TTestInvokeIntfMethods.Test18;
  1479. begin
  1480. DoIntfInvoke(18, [
  1481. GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
  1482. GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
  1483. ], [], GetSingleValue(SingleAddRes));
  1484. end;
  1485. procedure TTestInvokeIntfMethods.Test19;
  1486. begin
  1487. DoIntfInvoke(19, [
  1488. GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
  1489. GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
  1490. ], [], GetDoubleValue(DoubleAddRes));
  1491. end;
  1492. procedure TTestInvokeIntfMethods.Test20;
  1493. begin
  1494. DoIntfInvoke(20, [
  1495. GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
  1496. GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
  1497. ], [], GetExtendedValue(ExtendedAddRes));
  1498. end;
  1499. procedure TTestInvokeIntfMethods.Test21;
  1500. begin
  1501. DoIntfInvoke(21, [
  1502. GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
  1503. GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
  1504. ], [], GetCompValue(CompAddRes));
  1505. end;
  1506. procedure TTestInvokeIntfMethods.Test22;
  1507. begin
  1508. DoIntfInvoke(22, [
  1509. GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
  1510. GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
  1511. ], [], GetCurrencyValue(CurrencyAddRes));
  1512. end;
  1513. { ----------------------------------------------------------------------
  1514. TTestInvokeIntfMethodsRecs
  1515. ----------------------------------------------------------------------}
  1516. procedure TTestInvokeIntfMethodsRecs.Test1;
  1517. begin
  1518. DoIntfInvoke(1 or TTestInterfaceClass.RecSizeMarker,
  1519. [GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),False)], [],
  1520. GetRecValue(TypeInfo(TTestRecord1),Sizeof(TTestrecord1),True));
  1521. end;
  1522. procedure TTestInvokeIntfMethodsRecs.Test2;
  1523. begin
  1524. DoIntfInvoke(2 or TTestInterfaceClass.RecSizeMarker,
  1525. [GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),False)], [],
  1526. GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),True));
  1527. end;
  1528. procedure TTestInvokeIntfMethodsRecs.Test3;
  1529. begin
  1530. DoIntfInvoke(3 or TTestInterfaceClass.RecSizeMarker,
  1531. [GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),False)], [],
  1532. GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),True));
  1533. end;
  1534. procedure TTestInvokeIntfMethodsRecs.Test4;
  1535. begin
  1536. DoIntfInvoke(4 or TTestInterfaceClass.RecSizeMarker,
  1537. [GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),False)], [],
  1538. GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),True));
  1539. end;
  1540. procedure TTestInvokeIntfMethodsRecs.Test5;
  1541. begin
  1542. DoIntfInvoke(5 or TTestInterfaceClass.RecSizeMarker,
  1543. [GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),False)], [],
  1544. GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),True));
  1545. end;
  1546. procedure TTestInvokeIntfMethodsRecs.Test6;
  1547. begin
  1548. DoIntfInvoke(6 or TTestInterfaceClass.RecSizeMarker,
  1549. [GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),False)], [],
  1550. GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),True));
  1551. end;
  1552. procedure TTestInvokeIntfMethodsRecs.Test7;
  1553. begin
  1554. DoIntfInvoke(7 or TTestInterfaceClass.RecSizeMarker,
  1555. [GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),False)], [],
  1556. GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),True));
  1557. end;
  1558. procedure TTestInvokeIntfMethodsRecs.Test8;
  1559. begin
  1560. DoIntfInvoke(8 or TTestInterfaceClass.RecSizeMarker,
  1561. [GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),False)], [],
  1562. GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),True));
  1563. end;
  1564. procedure TTestInvokeIntfMethodsRecs.Test9;
  1565. begin
  1566. DoIntfInvoke(9 or TTestInterfaceClass.RecSizeMarker,
  1567. [GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),False)], [],
  1568. GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),True));
  1569. end;
  1570. procedure TTestInvokeIntfMethodsRecs.Test10;
  1571. begin
  1572. DoIntfInvoke(10 or TTestInterfaceClass.RecSizeMarker,
  1573. [GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),False)], [],
  1574. GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),True));
  1575. end;
  1576. { ----------------------------------------------------------------------
  1577. TTestInvokeMethodVars
  1578. ----------------------------------------------------------------------}
  1579. procedure TTestInvokeMethodVars.Test1;
  1580. begin
  1581. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test1), TypeInfo(TMethodTest1),1,[], [], TValue.empty);
  1582. end;
  1583. procedure TTestInvokeMethodVars.Test2;
  1584. begin
  1585. DoMethodInvoke(cls,TMethod({$ifdef fpc}@{$endif}cls.Test2), TypeInfo(TMethodTest2), 2, [], [], GetIntValue(42));
  1586. end;
  1587. procedure TTestInvokeMethodVars.Test3;
  1588. begin
  1589. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test3), TypeInfo(TMethodTest3), 3, [
  1590. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1591. ], [], GetIntValue(42));
  1592. end;
  1593. procedure TTestInvokeMethodVars.Test4;
  1594. begin
  1595. DoMethodInvoke(cls,
  1596. TMethod({$ifdef fpc}@{$endif}cls.Test4),TypeInfo(TMethodTest4), 4, [
  1597. GetAnsiString('Alpha'),
  1598. GetUnicodeString('Beta'),
  1599. GetWideString('Gamma'),
  1600. GetShortString('Delta')
  1601. ], [], TValue.Empty);
  1602. end;
  1603. procedure TTestInvokeMethodVars.Test5;
  1604. begin
  1605. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test5),TYpeInfo(TMethodTest5), 5, [], [], GetAnsiString('Hello World'));
  1606. end;
  1607. procedure TTestInvokeMethodVars.Test6;
  1608. begin
  1609. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test6),TypeInfo(TMethodTest6), 6, [], [], GetUnicodeString('Hello World'));
  1610. end;
  1611. procedure TTestInvokeMethodVars.Test7;
  1612. begin
  1613. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test7),TypeInfo(TMethodTest7), 7, [], [], GetWideString('Hello World'));
  1614. end;
  1615. procedure TTestInvokeMethodVars.Test8;
  1616. begin
  1617. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test8),TypeInfo(TMethodTest8), 8, [], [], GetShortString('Hello World'));
  1618. end;
  1619. procedure TTestInvokeMethodVars.Test9;
  1620. begin
  1621. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test9),TypeInfo(TMethodTest9), 9, [
  1622. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1623. ], [
  1624. GetIntValue($1234), GetIntValue($5678)
  1625. ], TValue.Empty);
  1626. end;
  1627. procedure TTestInvokeMethodVars.Test10;
  1628. begin
  1629. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test10),TypeInfo(TMethodTest10), 10, [
  1630. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1631. ], [
  1632. GetAnsiString('Foo'), GetAnsiString('Bar')
  1633. ], TValue.Empty);
  1634. end;
  1635. procedure TTestInvokeMethodVars.Test11;
  1636. begin
  1637. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test11),TypeInfo(TMethodTest11), 11, [
  1638. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1639. ], [
  1640. GetShortString('Foo'), GetShortString('Bar')
  1641. ], TValue.Empty);
  1642. end;
  1643. procedure TTestInvokeMethodVars.Test12;
  1644. begin
  1645. {$ifdef fpc}
  1646. DoMethodInvoke(cls,TMethod(@cls.Test12),TypeInfo(TMethodTest12), 12, [
  1647. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1648. ], [
  1649. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1650. ], TValue.Empty);
  1651. {$endif}
  1652. end;
  1653. procedure TTestInvokeMethodVars.Test13;
  1654. begin
  1655. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test13), Typeinfo(TMethodTest13), 13, [
  1656. GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
  1657. ], [
  1658. GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
  1659. ], GetSingleValue(SingleRes));
  1660. end;
  1661. procedure TTestInvokeMethodVars.Test14;
  1662. begin
  1663. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test14), TypeInfo(TMethodTest14), 14, [
  1664. GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
  1665. ], [
  1666. GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
  1667. ], GetDoubleValue(DoubleRes));
  1668. end;
  1669. procedure TTestInvokeMethodVars.Test15;
  1670. begin
  1671. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test15), TypeInfo(TMethodTest15),15, [
  1672. GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
  1673. ], [
  1674. GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
  1675. ], GetExtendedValue(ExtendedRes));
  1676. end;
  1677. procedure TTestInvokeMethodVars.Test16;
  1678. begin
  1679. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test16),TypeInfo(TMethodTest16), 16, [
  1680. GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
  1681. ], [
  1682. GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
  1683. ], GetCompValue(CompRes));
  1684. end;
  1685. procedure TTestInvokeMethodVars.Test17;
  1686. begin
  1687. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test17),TypeInfo(TMethodTest17), 17, [
  1688. GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
  1689. ], [
  1690. GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
  1691. ], GetCurrencyValue(CurrencyRes));
  1692. end;
  1693. procedure TTestInvokeMethodVars.Test18;
  1694. begin
  1695. DoMethodInvoke(cls,TMethod({$ifdef fpc}@{$endif}cls.Test18),TypeInfo(TMethodTest18), 18, [
  1696. GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
  1697. GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
  1698. ], [], GetSingleValue(SingleAddRes));
  1699. end;
  1700. procedure TTestInvokeMethodVars.Test19;
  1701. begin
  1702. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test19), TypeInfo(TMethodTest19), 19, [
  1703. GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
  1704. GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
  1705. ], [], GetDoubleValue(DoubleAddRes));
  1706. end;
  1707. procedure TTestInvokeMethodVars.Test20;
  1708. begin
  1709. DoMethodInvoke(cls, TMethod( {$ifdef fpc}@{$endif}cls.Test20),TypeInfo(TMethodTest20), 20, [
  1710. GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
  1711. GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
  1712. ], [], GetExtendedValue(ExtendedAddRes));
  1713. end;
  1714. procedure TTestInvokeMethodVars.Test21;
  1715. begin
  1716. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test21),TypeInfo(TMethodTest21), 21, [
  1717. GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
  1718. GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
  1719. ], [], GetCompValue(CompAddRes));
  1720. end;
  1721. procedure TTestInvokeMethodVars.Test22;
  1722. begin
  1723. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.Test22),TypeInfo(TMethodTest22), 22, [
  1724. GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
  1725. GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
  1726. ], [], GetCurrencyValue(CurrencyAddRes));
  1727. end;
  1728. { ----------------------------------------------------------------------
  1729. TTestInvokeMethodVarsRecs
  1730. ----------------------------------------------------------------------}
  1731. procedure TTestInvokeMethodVarsRecs.Test1;
  1732. begin
  1733. DoMethodInvoke(cls,TMethod({$ifdef fpc}@{$endif}cls.TestRecSize1), TypeInfo(TMethodTestRecSize1), 1 or TTestInterfaceClass.RecSizeMarker,
  1734. [GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),False)], [],
  1735. GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),True));
  1736. end;
  1737. procedure TTestInvokeMethodVarsRecs.Test2;
  1738. begin
  1739. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize2),TypeInfo(TMethodTestRecSize2), 2 or TTestInterfaceClass.RecSizeMarker,
  1740. [GetRecValue(TypeInfo(TTestRecord2),SizeOF(TTestrecord2),False)], [],
  1741. GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),True));
  1742. end;
  1743. procedure TTestInvokeMethodVarsRecs.Test3;
  1744. begin
  1745. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize3), TypeInfo(TMethodTestRecSize3), 3 or TTestInterfaceClass.RecSizeMarker,
  1746. [GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),False)], [],
  1747. GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),True));
  1748. end;
  1749. procedure TTestInvokeMethodVarsRecs.Test4;
  1750. begin
  1751. DoMethodInvoke(cls,TMethod({$ifdef fpc}@{$endif}cls.TestRecSize4), TypeInfo(TMethodTestRecSize4), 4 or TTestInterfaceClass.RecSizeMarker,
  1752. [GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),False)], [],
  1753. GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),True));
  1754. end;
  1755. procedure TTestInvokeMethodVarsRecs.Test5;
  1756. begin
  1757. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize5),TypeInfo(TMethodTestRecSize5), 5 or TTestInterfaceClass.RecSizeMarker,
  1758. [GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),False)], [],
  1759. GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),True));
  1760. end;
  1761. procedure TTestInvokeMethodVarsRecs.Test6;
  1762. begin
  1763. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize6), TypeInfo(TMethodTestRecSize6), 6 or TTestInterfaceClass.RecSizeMarker,
  1764. [GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),False)], [],
  1765. GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),True));
  1766. end;
  1767. procedure TTestInvokeMethodVarsRecs.Test7;
  1768. begin
  1769. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize7),TypeInfo(TMethodTestRecSize7), 7 or TTestInterfaceClass.RecSizeMarker,
  1770. [GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),False)], [],
  1771. GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),True));
  1772. end;
  1773. procedure TTestInvokeMethodVarsRecs.Test8;
  1774. begin
  1775. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize8), TypeInfo(TMethodTestRecSize8), 8 or TTestInterfaceClass.RecSizeMarker,
  1776. [GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),False)], [],
  1777. GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),True));
  1778. end;
  1779. procedure TTestInvokeMethodVarsRecs.Test9;
  1780. begin
  1781. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize9),TypeInfo(TMethodTestRecSize9), 9 or TTestInterfaceClass.RecSizeMarker,
  1782. [GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),False)], [],
  1783. GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),True));
  1784. end;
  1785. procedure TTestInvokeMethodVarsRecs.Test10;
  1786. begin
  1787. DoMethodInvoke(cls, TMethod({$ifdef fpc}@{$endif}cls.TestRecSize10),TypeInfo(TMethodTestRecSize10), 10 or TTestInterfaceClass.RecSizeMarker,
  1788. [GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),False)], [],
  1789. GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),True));
  1790. end;
  1791. { ----------------------------------------------------------------------
  1792. TTestInvokeProcVars
  1793. ----------------------------------------------------------------------}
  1794. procedure TTestInvokeProcVars.Test1;
  1795. begin
  1796. DoProcVarInvoke(CodePointer({$ifdef fpc}@{$endif}ProcTest1),TypeInfo(TProcVarTest1), 1, [], [], TValue.Empty);
  1797. end;
  1798. procedure TTestInvokeProcVars.Test2;
  1799. begin
  1800. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest2),TypeInfo(TProcVarTest2), 2, [], [], GetIntValue(42));
  1801. end;
  1802. procedure TTestInvokeProcVars.Test3;
  1803. begin
  1804. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest3),TypeInfo(TProcVarTest3), 3, [
  1805. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  1806. ], [], GetIntValue(42));
  1807. end;
  1808. procedure TTestInvokeProcVars.Test4;
  1809. begin
  1810. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest4), TypeInfo(TProcVarTest4), 4, [
  1811. GetAnsiString('Alpha'),
  1812. GetUnicodeString('Beta'),
  1813. GetWideString('Gamma'),
  1814. GetShortString('Delta')
  1815. ], [], TValue.Empty);
  1816. end;
  1817. procedure TTestInvokeProcVars.Test5;
  1818. begin
  1819. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest5), TypeInfo(TProcVarTest5), 5, [], [], GetAnsiString('Hello World'));
  1820. end;
  1821. procedure TTestInvokeProcVars.Test6;
  1822. begin
  1823. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest6), TypeInfo(TProcVarTest6), 6, [], [], GetUnicodeString('Hello World'));
  1824. end;
  1825. procedure TTestInvokeProcVars.Test7;
  1826. begin
  1827. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest7), TypeInfo(TProcVarTest7), 7, [], [], GetWideString('Hello World'));
  1828. end;
  1829. procedure TTestInvokeProcVars.Test8;
  1830. begin
  1831. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest8), TypeInfo(TProcVarTest8), 8, [], [], GetShortString('Hello World'));
  1832. end;
  1833. procedure TTestInvokeProcVars.Test9;
  1834. begin
  1835. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest9), TypeInfo(TProcVarTest9) , 9, [
  1836. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  1837. ], [
  1838. GetIntValue($1234), GetIntValue($5678)
  1839. ], TValue.Empty);
  1840. end;
  1841. procedure TTestInvokeProcVars.Test10;
  1842. begin
  1843. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest10), TypeInfo(TProcVarTest10), 10, [
  1844. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  1845. ], [
  1846. GetAnsiString('Foo'), GetAnsiString('Bar')
  1847. ], TValue.Empty);
  1848. end;
  1849. procedure TTestInvokeProcVars.Test11;
  1850. begin
  1851. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest11), TypeInfo(TProcVarTest11), 11, [
  1852. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  1853. ], [
  1854. GetShortString('Foo'), GetShortString('Bar')
  1855. ], TValue.Empty);
  1856. end;
  1857. procedure TTestInvokeProcVars.Test12;
  1858. begin
  1859. {$ifdef fpc}
  1860. DoProcVarInvoke(CodePointer(@ProcTest12), TypeInfo(TProcVarTest12), 12, [
  1861. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  1862. ], [
  1863. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  1864. ], TValue.Empty);
  1865. {$endif}
  1866. end;
  1867. procedure TTestInvokeProcVars.Test13;
  1868. begin
  1869. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest13),TypeInfo(TProcVarTest13), 13, [
  1870. GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
  1871. ], [
  1872. GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
  1873. ], GetSingleValue(SingleRes));
  1874. end;
  1875. procedure TTestInvokeProcVars.Test14;
  1876. begin
  1877. DoProcVarInvoke(CodePointer({$ifdef fpc}@{$endif}ProcTest14), TypeInfo(TProcVarTest14), 14, [
  1878. GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
  1879. ], [
  1880. GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
  1881. ], GetDoubleValue(DoubleRes));
  1882. end;
  1883. procedure TTestInvokeProcVars.Test15;
  1884. begin
  1885. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest15), TypeInfo(TProcVarTest15), 15, [
  1886. GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
  1887. ], [
  1888. GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
  1889. ], GetExtendedValue(ExtendedRes));
  1890. end;
  1891. procedure TTestInvokeProcVars.Test16;
  1892. begin
  1893. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest16), TypeInfo(TProcVarTest16), 16, [
  1894. GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
  1895. ], [
  1896. GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
  1897. ], GetCompValue(CompRes));
  1898. end;
  1899. procedure TTestInvokeProcVars.Test17;
  1900. begin
  1901. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest17), TypeInfo(TProcVarTest17), 17, [
  1902. GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
  1903. ], [
  1904. GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
  1905. ], GetCurrencyValue(CurrencyRes));
  1906. end;
  1907. procedure TTestInvokeProcVars.Test18;
  1908. begin
  1909. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest18), TypeInfo(TProcVarTest18), 18, [
  1910. GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
  1911. GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
  1912. ], [], GetSingleValue(SingleAddRes));
  1913. end;
  1914. procedure TTestInvokeProcVars.Test19;
  1915. begin
  1916. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest19), TypeInfo(TProcVarTest19), 19, [
  1917. GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
  1918. GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
  1919. ], [], GetDoubleValue(DoubleAddRes));
  1920. end;
  1921. procedure TTestInvokeProcVars.Test20;
  1922. begin
  1923. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest20), TypeInfo(TProcVarTest20), 20, [
  1924. GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
  1925. GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
  1926. ], [], GetExtendedValue(ExtendedAddRes));
  1927. end;
  1928. procedure TTestInvokeProcVars.Test21;
  1929. begin
  1930. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest21), TypeInfo(TProcVarTest21), 21, [
  1931. GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
  1932. GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
  1933. ], [], GetCompValue(CompAddRes));
  1934. end;
  1935. procedure TTestInvokeProcVars.Test22;
  1936. begin
  1937. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest22), TypeInfo(TProcVarTest22), 22, [
  1938. GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
  1939. GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
  1940. ], [], GetCurrencyValue(CurrencyAddRes));
  1941. end;
  1942. { ----------------------------------------------------------------------
  1943. TTestInvokeProcVarRecs
  1944. ----------------------------------------------------------------------}
  1945. procedure TTestInvokeProcVarRecs.Test1;
  1946. begin
  1947. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize1), TypeInfo(TProcVarTestRecSize1), 1 or TTestInterfaceClass.RecSizeMarker,
  1948. [GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),False)], [],
  1949. GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),True));
  1950. end;
  1951. procedure TTestInvokeProcVarRecs.Test2;
  1952. begin
  1953. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize2), TypeInfo(TProcVarTestRecSize2), 2 or TTestInterfaceClass.RecSizeMarker,
  1954. [GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),False)], [],
  1955. GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),True));
  1956. end;
  1957. procedure TTestInvokeProcVarRecs.Test3;
  1958. begin
  1959. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize3), TypeInfo(TProcVarTestRecSize3), 3 or TTestInterfaceClass.RecSizeMarker,
  1960. [GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),False)], [],
  1961. GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),True));
  1962. end;
  1963. procedure TTestInvokeProcVarRecs.Test4;
  1964. begin
  1965. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize4), TypeInfo(TProcVarTestRecSize4), 4 or TTestInterfaceClass.RecSizeMarker,
  1966. [GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),False)], [],
  1967. GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),True));
  1968. end;
  1969. procedure TTestInvokeProcVarRecs.Test5;
  1970. begin
  1971. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize5), TypeInfo(TProcVarTestRecSize5), 5 or TTestInterfaceClass.RecSizeMarker,
  1972. [GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),False)], [],
  1973. GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),True));
  1974. end;
  1975. procedure TTestInvokeProcVarRecs.Test6;
  1976. begin
  1977. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize6), TypeInfo(TProcVarTestRecSize6), 6 or TTestInterfaceClass.RecSizeMarker,
  1978. [GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),False)], [],
  1979. GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),True));
  1980. end;
  1981. procedure TTestInvokeProcVarRecs.Test7;
  1982. begin
  1983. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize7), TypeInfo(TProcVarTestRecSize7), 7 or TTestInterfaceClass.RecSizeMarker,
  1984. [GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),False)], [],
  1985. GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),True));
  1986. end;
  1987. procedure TTestInvokeProcVarRecs.Test8;
  1988. begin
  1989. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize8), TypeInfo(TProcVarTestRecSize8), 8 or TTestInterfaceClass.RecSizeMarker,
  1990. [GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),False)], [],
  1991. GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),True));
  1992. end;
  1993. procedure TTestInvokeProcVarRecs.Test9;
  1994. begin
  1995. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize9), TypeInfo(TProcVarTestRecSize9), 9 or TTestInterfaceClass.RecSizeMarker,
  1996. [GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),False)], [],
  1997. GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),True));
  1998. end;
  1999. procedure TTestInvokeProcVarRecs.Test10;
  2000. begin
  2001. DoProcVarInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize10), TypeInfo(TProcVarTestRecSize10), 10 or TTestInterfaceClass.RecSizeMarker,
  2002. [GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),False)], [],
  2003. GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),True));
  2004. end;
  2005. { TTestInvokeTestProc }
  2006. procedure TTestInvokeTestProc.Test1;
  2007. begin
  2008. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest1),TypeInfo(TProcVarTest1), 1, [], [], TValue.Empty);
  2009. end;
  2010. procedure TTestInvokeTestProc.Test2;
  2011. begin
  2012. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest2),TypeInfo(TProcVarTest2), 2, [], [], GetIntValue(42));
  2013. end;
  2014. procedure TTestInvokeTestProc.Test3;
  2015. begin
  2016. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest3),TypeInfo(TProcVarTest3), 3, [
  2017. GetIntValue(7), GetIntValue(2), GetIntValue(5), GetIntValue(1), GetIntValue(10), GetIntValue(8), GetIntValue(6), GetIntValue(3), GetIntValue(9), GetIntValue(3)
  2018. ], [], GetIntValue(42));
  2019. end;
  2020. procedure TTestInvokeTestProc.Test4;
  2021. begin
  2022. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest4),TypeInfo(TProcVarTest4), 4, [
  2023. GetAnsiString('Alpha'),
  2024. GetUnicodeString('Beta'),
  2025. GetWideString('Gamma'),
  2026. GetShortString('Delta')
  2027. ], [], TValue.Empty);
  2028. end;
  2029. procedure TTestInvokeTestProc.Test5;
  2030. begin
  2031. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest5),TypeInfo(TProcVarTest5), 5, [], [], GetAnsiString('Hello World'));
  2032. end;
  2033. procedure TTestInvokeTestProc.Test6;
  2034. begin
  2035. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest6),TypeInfo(TProcVarTest6), 6, [], [], GetUnicodeString('Hello World'));
  2036. end;
  2037. procedure TTestInvokeTestProc.Test7;
  2038. begin
  2039. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest7),TypeInfo(TProcVarTest7), 7, [], [], GetWideString('Hello World'));
  2040. end;
  2041. procedure TTestInvokeTestProc.Test8;
  2042. begin
  2043. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest8),TypeInfo(TProcVarTest8), 8, [], [], GetShortString('Hello World'));
  2044. end;
  2045. {$ifdef NEEDS_POINTER_HELPER}
  2046. procedure TTestInvokeTestProc.Test9;
  2047. begin
  2048. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest9),TypeInfo(TProcVarTest9), 9, [
  2049. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  2050. ], [
  2051. GetIntValue($1234), GetIntValue($5678)
  2052. ], TValue.Empty);
  2053. end;
  2054. procedure TTestInvokeTestProc.Test10;
  2055. begin
  2056. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest10),TypeInfo(TProcVarTest10), 10, [
  2057. GetAnsiString('Alpha'), GetAnsiString('Beta'), GetAnsiString(''), GetAnsiString('Delta')
  2058. ], [
  2059. GetAnsiString('Foo'), GetAnsiString('Bar')
  2060. ], TValue.Empty);
  2061. end;
  2062. procedure TTestInvokeTestProc.Test11;
  2063. begin
  2064. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest11),TypeInfo(TProcVarTest11), 11, [
  2065. GetShortString('Alpha'), GetShortString('Beta'), GetShortString(''), GetShortString('Delta')
  2066. ], [
  2067. GetShortString('Foo'), GetShortString('Bar')
  2068. ], TValue.Empty);
  2069. end;
  2070. procedure TTestInvokeTestProc.Test12;
  2071. begin
  2072. {$ifdef fpc}
  2073. DoProcInvoke(CodePointer({$ifdef fpc}@{$endif}ProcTest12),TypeInfo(TProcVarTest12), 12, [
  2074. GetArray([$1234, $2345, $3456, $4567]), GetArray([$4321, $5431, $6543, $7654]), GetArray([$5678, $6789, $7890, $8901]), GetArray([$8765, $7654, $6543, $5432])
  2075. ], [
  2076. GetArray([$4321, $4322, $4323, $4324]), GetArray([$9876, $9877, $9878, $9879])
  2077. ], TValue.Empty);
  2078. {$endif}
  2079. end;
  2080. procedure TTestInvokeTestProc.Test13;
  2081. begin
  2082. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest13),TypeInfo(TProcVarTest13), 13, [
  2083. GetSingleValue(SingleArg1), GetSingleValue(SingleArg2In), GetSingleValue(0), GetSingleValue(SingleArg4)
  2084. ], [
  2085. GetSingleValue(SingleArg2Out), GetSingleValue(SingleArg3Out)
  2086. ], GetSingleValue(SingleRes));
  2087. end;
  2088. procedure TTestInvokeTestProc.Test14;
  2089. begin
  2090. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest14),TypeInfo(TProcVarTest14), 14, [
  2091. GetDoubleValue(DoubleArg1), GetDoubleValue(DoubleArg2In), GetDoubleValue(0), GetDoubleValue(DoubleArg4)
  2092. ], [
  2093. GetDoubleValue(DoubleArg2Out), GetDoubleValue(DoubleArg3Out)
  2094. ], GetDoubleValue(DoubleRes));
  2095. end;
  2096. procedure TTestInvokeTestProc.Test15;
  2097. begin
  2098. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest15),TypeInfo(TProcVarTest15), 15, [
  2099. GetExtendedValue(ExtendedArg1), GetExtendedValue(ExtendedArg2In), GetExtendedValue(0), GetExtendedValue(ExtendedArg4)
  2100. ], [
  2101. GetExtendedValue(ExtendedArg2Out), GetExtendedValue(ExtendedArg3Out)
  2102. ], GetExtendedValue(ExtendedRes));
  2103. end;
  2104. procedure TTestInvokeTestProc.Test16;
  2105. begin
  2106. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest16),TypeInfo(TProcVarTest16), 16, [
  2107. GetCompValue(CompArg1), GetCompValue(CompArg2In), GetCompValue(0), GetCompValue(CompArg4)
  2108. ], [
  2109. GetCompValue(CompArg2Out), GetCompValue(CompArg3Out)
  2110. ], GetCompValue(CompRes));
  2111. end;
  2112. procedure TTestInvokeTestProc.Test17;
  2113. begin
  2114. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest17),TypeInfo(TProcVarTest17), 17, [
  2115. GetCurrencyValue(CurrencyArg1), GetCurrencyValue(CurrencyArg2In), GetCurrencyValue(0), GetCurrencyValue(CurrencyArg4)
  2116. ], [
  2117. GetCurrencyValue(CurrencyArg2Out), GetCurrencyValue(CurrencyArg3Out)
  2118. ], GetCurrencyValue(CurrencyRes));
  2119. end;
  2120. {$endif NEEDS_POINTER_HELPER}
  2121. procedure TTestInvokeTestProc.Test18;
  2122. begin
  2123. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest18),TypeInfo(TProcVarTest18), 18, [
  2124. GetSingleValue(SingleAddArg1), GetSingleValue(SingleAddArg2), GetSingleValue(SingleAddArg3), GetSingleValue(SingleAddArg4), GetSingleValue(SingleAddArg5),
  2125. GetSingleValue(SingleAddArg6), GetSingleValue(SingleAddArg7), GetSingleValue(SingleAddArg8), GetSingleValue(SingleAddArg9), GetSingleValue(SingleAddArg10)
  2126. ], [], GetSingleValue(SingleAddRes));
  2127. end;
  2128. procedure TTestInvokeTestProc.Test19;
  2129. begin
  2130. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest19),TypeInfo(TProcVarTest19), 19, [
  2131. GetDoubleValue(DoubleAddArg1), GetDoubleValue(DoubleAddArg2), GetDoubleValue(DoubleAddArg3), GetDoubleValue(DoubleAddArg4), GetDoubleValue(DoubleAddArg5),
  2132. GetDoubleValue(DoubleAddArg6), GetDoubleValue(DoubleAddArg7), GetDoubleValue(DoubleAddArg8), GetDoubleValue(DoubleAddArg9), GetDoubleValue(DoubleAddArg10)
  2133. ], [], GetDoubleValue(DoubleAddRes));
  2134. end;
  2135. procedure TTestInvokeTestProc.Test20;
  2136. begin
  2137. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest20),TypeInfo(TProcVarTest20), 20, [
  2138. GetExtendedValue(ExtendedAddArg1), GetExtendedValue(ExtendedAddArg2), GetExtendedValue(ExtendedAddArg3), GetExtendedValue(ExtendedAddArg4), GetExtendedValue(ExtendedAddArg5),
  2139. GetExtendedValue(ExtendedAddArg6), GetExtendedValue(ExtendedAddArg7), GetExtendedValue(ExtendedAddArg8), GetExtendedValue(ExtendedAddArg9), GetExtendedValue(ExtendedAddArg10)
  2140. ], [], GetExtendedValue(ExtendedAddRes));
  2141. end;
  2142. procedure TTestInvokeTestProc.Test21;
  2143. begin
  2144. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest21),TypeInfo(TProcVarTest21), 21, [
  2145. GetCompValue(CompAddArg1), GetCompValue(CompAddArg2), GetCompValue(CompAddArg3), GetCompValue(CompAddArg4), GetCompValue(CompAddArg5),
  2146. GetCompValue(CompAddArg6), GetCompValue(CompAddArg7), GetCompValue(CompAddArg8), GetCompValue(CompAddArg9), GetCompValue(CompAddArg10)
  2147. ], [], GetCompValue(CompAddRes));
  2148. end;
  2149. procedure TTestInvokeTestProc.Test22;
  2150. begin
  2151. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTest22),TypeInfo(TProcVarTest22), 22, [
  2152. GetCurrencyValue(CurrencyAddArg1), GetCurrencyValue(CurrencyAddArg2), GetCurrencyValue(CurrencyAddArg3), GetCurrencyValue(CurrencyAddArg4), GetCurrencyValue(CurrencyAddArg5),
  2153. GetCurrencyValue(CurrencyAddArg6), GetCurrencyValue(CurrencyAddArg7), GetCurrencyValue(CurrencyAddArg8), GetCurrencyValue(CurrencyAddArg9), GetCurrencyValue(CurrencyAddArg10)
  2154. ], [], GetCurrencyValue(CurrencyAddRes));
  2155. end;
  2156. { TTestInvokeTestProcRecs }
  2157. procedure TTestInvokeTestProcRecs.Test1;
  2158. begin
  2159. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize1),TypeInfo(TProcVarTestRecSize1), 1 or TTestInterfaceClass.RecSizeMarker,
  2160. [GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),False)], [],
  2161. GetRecValue(TypeInfo(TTestRecord1),SizeOf(TTestRecord1),True));
  2162. end;
  2163. procedure TTestInvokeTestProcRecs.Test2;
  2164. begin
  2165. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize2),TypeInfo(TProcVarTestRecSize2), 2 or TTestInterfaceClass.RecSizeMarker,
  2166. [GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),False)], [],
  2167. GetRecValue(TypeInfo(TTestRecord2),SizeOf(TTestRecord2),True));
  2168. end;
  2169. procedure TTestInvokeTestProcRecs.Test3;
  2170. begin
  2171. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize3),TypeInfo(TProcVarTestRecSize3), 3 or TTestInterfaceClass.RecSizeMarker,
  2172. [GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),False)], [],
  2173. GetRecValue(TypeInfo(TTestRecord3),SizeOf(TTestRecord3),True));
  2174. end;
  2175. procedure TTestInvokeTestProcRecs.Test4;
  2176. begin
  2177. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize4),TypeInfo(TProcVarTestRecSize4), 4 or TTestInterfaceClass.RecSizeMarker,
  2178. [GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),False)], [],
  2179. GetRecValue(TypeInfo(TTestRecord4),SizeOf(TTestRecord4),True));
  2180. end;
  2181. procedure TTestInvokeTestProcRecs.Test5;
  2182. begin
  2183. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize5),TypeInfo(TProcVarTestRecSize5), 5 or TTestInterfaceClass.RecSizeMarker,
  2184. [GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),False)], [],
  2185. GetRecValue(TypeInfo(TTestRecord5),SizeOf(TTestRecord5),True));
  2186. end;
  2187. procedure TTestInvokeTestProcRecs.Test6;
  2188. begin
  2189. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize6),TypeInfo(TProcVarTestRecSize6), 6 or TTestInterfaceClass.RecSizeMarker,
  2190. [GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),False)], [],
  2191. GetRecValue(TypeInfo(TTestRecord6),SizeOf(TTestRecord6),True));
  2192. end;
  2193. procedure TTestInvokeTestProcRecs.Test7;
  2194. begin
  2195. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize7),TypeInfo(TProcVarTestRecSize7), 7 or TTestInterfaceClass.RecSizeMarker,
  2196. [GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),False)], [],
  2197. GetRecValue(TypeInfo(TTestRecord7),SizeOf(TTestRecord7),True));
  2198. end;
  2199. procedure TTestInvokeTestProcRecs.Test8;
  2200. begin
  2201. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize8),TypeInfo(TProcVarTestRecSize8), 8 or TTestInterfaceClass.RecSizeMarker,
  2202. [GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),False)], [],
  2203. GetRecValue(TypeInfo(TTestRecord8),SizeOf(TTestRecord8),True));
  2204. end;
  2205. procedure TTestInvokeTestProcRecs.Test9;
  2206. begin
  2207. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize9),TypeInfo(TProcVarTestRecSize9), 9 or TTestInterfaceClass.RecSizeMarker,
  2208. [GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),False)], [],
  2209. GetRecValue(TypeInfo(TTestRecord9),SizeOf(TTestRecord9),True));
  2210. end;
  2211. procedure TTestInvokeTestProcRecs.Test10;
  2212. begin
  2213. DoProcInvoke(CodePointer( {$ifdef fpc}@{$endif}ProcTestRecSize10),TypeInfo(TProcVarTestRecSize10), 10 or TTestInterfaceClass.RecSizeMarker,
  2214. [GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),False)], [],
  2215. GetRecValue(TypeInfo(TTestRecord10),SizeOf(TTestRecord10),True));
  2216. end;
  2217. { TTestInvokeUntyped }
  2218. procedure TTestInvokeUntyped.Test1;
  2219. begin
  2220. DoUntypedInvoke(CodePointer(Nil), Default(TMethod), PTypeInfo(Nil), [
  2221. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  2222. ], [
  2223. GetIntValue($4321), GetIntValue($5678)
  2224. ]);
  2225. end;
  2226. procedure TTestInvokeUntyped.Test2;
  2227. begin
  2228. DoUntypedInvoke(CodePointer(Nil), Default(TMethod), PTypeInfo(Nil), [
  2229. GetAnsiString('Str1'),
  2230. GetAnsiString('Str2'),
  2231. GetAnsiString('Str3'),
  2232. GetAnsiString('Str4')
  2233. ], [
  2234. GetAnsiString('StrVar'),
  2235. GetAnsiString('StrOut')
  2236. ]);
  2237. end;
  2238. procedure TTestInvokeUntyped.Test3;
  2239. begin
  2240. DoUntypedInvoke(CodePointer(Nil), Default(TMethod), PTypeInfo(Nil), [
  2241. GetShortString('Str1'),
  2242. GetShortString('Str2'),
  2243. GetShortString('Str3'),
  2244. GetShortString('Str4')
  2245. ], [
  2246. GetShortString('StrVar'),
  2247. GetShortString('StrOut')
  2248. ]);
  2249. end;
  2250. procedure TTestInvokeUntyped.Test4;
  2251. begin
  2252. DoUntypedInvoke(Nil, TMethod({$ifdef fpc}@{$endif}cls.TestUntyped), TypeInfo(TMethodTestUntyped), [
  2253. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  2254. ], [
  2255. GetIntValue($4321), GetIntValue($5678)
  2256. ]);
  2257. end;
  2258. procedure TTestInvokeUntyped.Test5;
  2259. begin
  2260. DoUntypedInvoke(Nil, TMethod({$ifdef fpc}@{$endif}cls.TestUntyped), TypeInfo(TMethodTestUntyped), [
  2261. GetAnsiString('Str1'),
  2262. GetAnsiString('Str2'),
  2263. GetAnsiString('Str3'),
  2264. GetAnsiString('Str4')
  2265. ], [
  2266. GetAnsiString('StrVar'),
  2267. GetAnsiString('StrOut')
  2268. ]);
  2269. end;
  2270. procedure TTestInvokeUntyped.Test6;
  2271. begin
  2272. DoUntypedInvoke(Nil, TMethod({$ifdef fpc}@{$endif}cls.TestUntyped), TypeInfo(TMethodTestUntyped), [
  2273. GetShortString('Str1'),
  2274. GetShortString('Str2'),
  2275. GetShortString('Str3'),
  2276. GetShortString('Str4')
  2277. ], [
  2278. GetShortString('StrVar'),
  2279. GetShortString('StrOut')
  2280. ]);
  2281. end;
  2282. procedure TTestInvokeUntyped.Test7;
  2283. begin
  2284. DoUntypedInvoke({$ifdef fpc}@{$endif}ProcTestUntyped, Default(TMethod), TypeInfo(TProcVarTestUntyped), [
  2285. GetIntValue($1234), GetIntValue($4321), GetIntValue($8765), GetIntValue($5678)
  2286. ], [
  2287. GetIntValue($4321), GetIntValue($5678)
  2288. ]);
  2289. end;
  2290. procedure TTestInvokeUntyped.Test8;
  2291. begin
  2292. DoUntypedInvoke({$ifdef fpc}@{$endif}ProcTestUntyped, Default(TMethod), TypeInfo(TProcVarTestUntyped), [
  2293. GetAnsiString('Str1'),
  2294. GetAnsiString('Str2'),
  2295. GetAnsiString('Str3'),
  2296. GetAnsiString('Str4')
  2297. ], [
  2298. GetAnsiString('StrVar'),
  2299. GetAnsiString('StrOut')
  2300. ]);
  2301. end;
  2302. procedure TTestInvokeUntyped.Test9;
  2303. begin
  2304. DoUntypedInvoke({$ifdef fpc}@{$endif}ProcTestUntyped, Default(TMethod), TypeInfo(TProcVarTestUntyped), [
  2305. GetShortString('Str1'),
  2306. GetShortString('Str2'),
  2307. GetShortString('Str3'),
  2308. GetShortString('Str4')
  2309. ], [
  2310. GetShortString('StrVar'),
  2311. GetShortString('StrOut')
  2312. ]);
  2313. end;
  2314. begin
  2315. {$ifdef fpc}
  2316. RegisterTest(TTestInvoke);
  2317. RegisterTest(TTestInvokeIntfMethods);
  2318. RegisterTest(TTestInvokeIntfMethodsRecs);
  2319. RegisterTest(TTestInvokeMethodVars);
  2320. RegisterTest(TTestInvokeMethodVarsRecs);
  2321. RegisterTest(TTestInvokeProcVars);
  2322. RegisterTest(TTestInvokeProcVarRecs);
  2323. RegisterTest(TTestInvokeTestProc);
  2324. RegisterTest(TTestInvokeTestProcRecs);
  2325. RegisterTest(TTestInvokeUntyped);
  2326. {$else fpc}
  2327. RegisterTest(TTestInvoke.Suite);
  2328. RegisterTest(TTestInvokeIntfMethods.Suite);
  2329. RegisterTest(TTestInvokeIntfMethodsRecs.Suite);
  2330. RegisterTest(TTestInvokeMethodVars.Suite);
  2331. RegisterTest(TTestInvokeMethodVarsRecs.Suite);
  2332. RegisterTest(TTestInvokeProcVars.Suite);
  2333. RegisterTest(TTestInvokeProcVarRecs.Suite);
  2334. RegisterTest(TTestInvokeTestProc.Suite);
  2335. RegisterTest(TTestInvokeTestProcRecs.Suite);
  2336. RegisterTest(TTestInvokeUntyped.Suite);
  2337. {$endif fpc}
  2338. end.