tcgenerics.pas 72 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815
  1. unit TCGenerics;
  2. {$mode objfpc}{$H+}
  3. interface
  4. uses
  5. Classes, SysUtils, fpcunit, testregistry,
  6. TCModules, FPPas2Js, PScanner, PasResolveEval;
  7. type
  8. { TTestGenerics }
  9. TTestGenerics = class(TCustomTestModule)
  10. Published
  11. // generic record
  12. Procedure TestGen_RecordEmpty;
  13. Procedure TestGen_Record_ClassProc;
  14. Procedure TestGen_Record_ClassVarRecord_Program;
  15. Procedure TestGen_Record_ClassVarRecord_UnitImpl;
  16. Procedure TestGen_Record_RTTI_UnitImpl;
  17. procedure TestGen_Record_Delay_UsedByImplUses;
  18. // ToDo: type alias type as parameter, TBird = type word;
  19. // generic class
  20. Procedure TestGen_ClassEmpty;
  21. Procedure TestGen_Class_EmptyMethod;
  22. Procedure TestGen_Class_TList;
  23. Procedure TestGen_Class_TCustomList; // ToDo: with Self do Result:=Method()
  24. Procedure TestGen_ClassAncestor;
  25. Procedure TestGen_Class_TypeInfo;
  26. Procedure TestGen_Class_TypeOverload; // ToDo TBird, TBird<T>, TBird<S,T>
  27. Procedure TestGen_Class_ClassProperty;
  28. Procedure TestGen_Class_ClassProc;
  29. //Procedure TestGen_Record_ReferGenClass_DelphiFail; TBird<T> = class x:TBird; end;
  30. Procedure TestGen_Class_ClassConstructor;
  31. Procedure TestGen_Class_TypeCastSpecializesWarn;
  32. Procedure TestGen_Class_TypeCastSpecializesJSValueNoWarn;
  33. procedure TestGen_Class_OverloadsInUnit;
  34. procedure TestGen_ClassForward_CircleRTTI;
  35. procedure TestGen_Class_Nested_RTTI;
  36. Procedure TestGen_Class_ClassVarRecord_UnitImpl;
  37. // generic external class
  38. procedure TestGen_ExtClass_VarArgsOfType;
  39. procedure TestGen_ExtClass_Array;
  40. procedure TestGen_ExtClass_GenJSValueAssign;
  41. procedure TestGen_ExtClass_AliasMemberType;
  42. Procedure TestGen_ExtClass_RTTI;
  43. procedure TestGen_ExtClass_UnitImplRec;
  44. // class interfaces
  45. procedure TestGen_ClassInterface_Corba;
  46. procedure TestGen_ClassInterface_InterfacedObject;
  47. procedure TestGen_ClassInterface_COM_RTTI;
  48. procedure TestGen_ClassInterface_Helper;
  49. procedure TestGen_ClassInterface_DelayedInitSpec;
  50. // statements
  51. Procedure TestGen_InlineSpec_Constructor;
  52. Procedure TestGen_CallUnitImplProc;
  53. Procedure TestGen_IntAssignTemplVar;
  54. Procedure TestGen_TypeCastDotField;
  55. Procedure TestGen_Except;
  56. // generic helper
  57. procedure TestGen_HelperForArray;
  58. // generic functions
  59. procedure TestGenProc_Function_ObjFPC;
  60. procedure TestGenProc_Function_Delphi;
  61. procedure TestGenProc_Overload;
  62. procedure TestGenProc_Forward;
  63. procedure TestGenProc_Infer_OverloadForward;
  64. procedure TestGenProc_TypeInfo;
  65. procedure TestGenProc_Infer_Widen;
  66. procedure TestGenProc_Infer_PassAsArg;
  67. procedure TestGenProc_AnonymousProc;
  68. // ToDo: FuncName:= instead of Result:=
  69. // generic methods
  70. procedure TestGenMethod_ImplicitSpec_ObjFPC;
  71. procedure TestGenMethod_Delphi;
  72. // generic array
  73. procedure TestGen_Array_OtherUnit;
  74. procedure TestGen_ArrayOfUnitImplRec;
  75. procedure TestGen_Array_TypecastJSValueResultToArg;
  76. // generic procedure type
  77. procedure TestGen_ProcType_ProcLocal;
  78. procedure TestGen_ProcType_Local_RTTI_Fail;
  79. procedure TestGen_ProcType_ParamUnitImpl;
  80. end;
  81. implementation
  82. { TTestGenerics }
  83. procedure TTestGenerics.TestGen_RecordEmpty;
  84. begin
  85. StartProgram(false);
  86. Add([
  87. 'type',
  88. ' generic TRecA<T> = record',
  89. ' end;',
  90. 'var a,b: specialize TRecA<word>;',
  91. 'begin',
  92. ' if a=b then ;']);
  93. ConvertProgram;
  94. CheckSource('TestGen_RecordEmpty',
  95. LinesToStr([ // statements
  96. 'rtl.recNewT(this, "TRecA$G1", function () {',
  97. ' this.$eq = function (b) {',
  98. ' return true;',
  99. ' };',
  100. ' this.$assign = function (s) {',
  101. ' return this;',
  102. ' };',
  103. '});',
  104. 'this.a = this.TRecA$G1.$new();',
  105. 'this.b = this.TRecA$G1.$new();',
  106. '']),
  107. LinesToStr([ // $mod.$main
  108. 'if ($mod.a.$eq($mod.b)) ;'
  109. ]));
  110. end;
  111. procedure TTestGenerics.TestGen_Record_ClassProc;
  112. begin
  113. StartProgram(false);
  114. Add([
  115. '{$modeswitch AdvancedRecords}',
  116. 'type',
  117. ' generic TPoint<T> = record',
  118. ' class var x: T;',
  119. ' class procedure Fly; static;',
  120. ' end;',
  121. 'class procedure Tpoint.Fly;',
  122. 'begin',
  123. ' x:=x+3;',
  124. ' tpoint.x:=tpoint.x+4;',
  125. ' Fly;',
  126. ' tpoint.Fly;',
  127. 'end;',
  128. 'var p: specialize TPoint<word>;',
  129. 'begin',
  130. ' p.x:=p.x+10;',
  131. ' p.Fly;',
  132. ' p.Fly();',
  133. '']);
  134. ConvertProgram;
  135. CheckSource('TestGen_Record_ClassProc',
  136. LinesToStr([ // statements
  137. 'rtl.recNewT(this, "TPoint$G1", function () {',
  138. ' this.x = 0;',
  139. ' this.$eq = function (b) {',
  140. ' return true;',
  141. ' };',
  142. ' this.$assign = function (s) {',
  143. ' return this;',
  144. ' };',
  145. ' this.Fly = function () {',
  146. ' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 3;',
  147. ' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 4;',
  148. ' $mod.TPoint$G1.Fly();',
  149. ' $mod.TPoint$G1.Fly();',
  150. ' };',
  151. '}, true);',
  152. 'this.p = this.TPoint$G1.$new();',
  153. '']),
  154. LinesToStr([ // $mod.$main
  155. '$mod.TPoint$G1.x = $mod.p.x + 10;',
  156. '$mod.TPoint$G1.Fly();',
  157. '$mod.TPoint$G1.Fly();',
  158. '']));
  159. end;
  160. procedure TTestGenerics.TestGen_Record_ClassVarRecord_Program;
  161. begin
  162. StartProgram(false);
  163. Add([
  164. '{$modeswitch AdvancedRecords}',
  165. 'type',
  166. ' generic TAnt<T> = record',
  167. ' class var x: T;',
  168. ' end;',
  169. ' TBird = record',
  170. ' b: word;',
  171. ' end;',
  172. 'var f: specialize TAnt<TBird>;',
  173. 'begin',
  174. ' f.x.b:=f.x.b+10;',
  175. '']);
  176. ConvertProgram;
  177. CheckSource('TestGen_Record_ClassVarRecord_Program',
  178. LinesToStr([ // statements
  179. 'rtl.recNewT(this, "TBird", function () {',
  180. ' this.b = 0;',
  181. ' this.$eq = function (b) {',
  182. ' return this.b === b.b;',
  183. ' };',
  184. ' this.$assign = function (s) {',
  185. ' this.b = s.b;',
  186. ' return this;',
  187. ' };',
  188. '});',
  189. 'rtl.recNewT(this, "TAnt$G1", function () {',
  190. ' this.x = $mod.TBird.$new();',
  191. ' this.$eq = function (b) {',
  192. ' return true;',
  193. ' };',
  194. ' this.$assign = function (s) {',
  195. ' return this;',
  196. ' };',
  197. '}, true);',
  198. 'this.f = this.TAnt$G1.$new();',
  199. '']),
  200. LinesToStr([ // $mod.$main
  201. '$mod.f.x.b = $mod.f.x.b + 10;',
  202. '']));
  203. end;
  204. procedure TTestGenerics.TestGen_Record_ClassVarRecord_UnitImpl;
  205. begin
  206. StartProgram(true,[supTObject]);
  207. AddModuleWithIntfImplSrc('UnitA.pas',
  208. LinesToStr([
  209. '{$modeswitch AdvancedRecords}',
  210. 'type',
  211. ' generic TAnt<T> = record',
  212. ' class var x: T;',
  213. ' class var a: array[1..2] of T;',
  214. ' end;',
  215. '']),
  216. LinesToStr([
  217. 'type',
  218. ' TBird = record',
  219. ' b: word;',
  220. ' end;',
  221. 'var f: specialize TAnt<TBird>;',
  222. 'begin',
  223. ' f.x.b:=f.x.b+10;',
  224. '']));
  225. Add([
  226. 'uses UnitA;',
  227. 'begin',
  228. 'end.']);
  229. ConvertProgram;
  230. CheckUnit('UnitA.pas',
  231. LinesToStr([ // statements
  232. 'rtl.module("UnitA", ["system"], function () {',
  233. ' var $mod = this;',
  234. ' var $impl = $mod.$impl;',
  235. ' rtl.recNewT(this, "TAnt$G1", function () {',
  236. ' this.$initSpec = function () {',
  237. ' this.x = $impl.TBird.$new();',
  238. ' this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
  239. ' };',
  240. ' this.a$a$clone = function (a) {',
  241. ' var r = [];',
  242. ' for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
  243. ' return r;',
  244. ' };',
  245. ' this.$eq = function (b) {',
  246. ' return true;',
  247. ' };',
  248. ' this.$assign = function (s) {',
  249. ' return this;',
  250. ' };',
  251. ' }, true);',
  252. ' $mod.$implcode = function () {',
  253. ' rtl.recNewT($impl, "TBird", function () {',
  254. ' this.b = 0;',
  255. ' this.$eq = function (b) {',
  256. ' return this.b === b.b;',
  257. ' };',
  258. ' this.$assign = function (s) {',
  259. ' this.b = s.b;',
  260. ' return this;',
  261. ' };',
  262. ' });',
  263. ' $impl.f = $mod.TAnt$G1.$new();',
  264. ' };',
  265. ' $mod.$init = function () {',
  266. ' $impl.f.x.b = $impl.f.x.b + 10;',
  267. ' };',
  268. '}, []);']));
  269. CheckSource('TestGen_Record_ClassVarRecord_UnitImpl',
  270. LinesToStr([ // statements
  271. '$mod.$implcode = function () {',
  272. ' pas.UnitA.TAnt$G1.$initSpec();',
  273. '};',
  274. '']),
  275. LinesToStr([ // $mod.$main
  276. '']));
  277. end;
  278. procedure TTestGenerics.TestGen_Record_RTTI_UnitImpl;
  279. begin
  280. WithTypeInfo:=true;
  281. StartUnit(true);
  282. Add([
  283. 'interface',
  284. '{$modeswitch AdvancedRecords}',
  285. 'type',
  286. ' generic TAnt<T> = record',
  287. ' class var x: T;',
  288. //' class var a,b: array of T;',
  289. ' end;',
  290. 'implementation',
  291. 'type',
  292. ' TBird = record',
  293. ' b: word;',
  294. ' end;',
  295. 'var f: specialize TAnt<TBird>;',
  296. ' p: pointer;',
  297. 'begin',
  298. ' p:=typeinfo(f);',
  299. '']);
  300. ConvertUnit;
  301. CheckSource('TestGen_Record_RTTI_UnitImpl',
  302. LinesToStr([ // statements
  303. 'var $impl = $mod.$impl;',
  304. 'rtl.recNewT(this, "TAnt$G1", function () {',
  305. ' var $r = $mod.$rtti.$Record("TAnt<Test1.TBird>", {});',
  306. ' this.$initSpec = function () {',
  307. ' this.x = $impl.TBird.$new();',
  308. ' $r.addField("x", $mod.$rtti["TBird"]);',
  309. ' };',
  310. ' this.$eq = function (b) {',
  311. ' return true;',
  312. ' };',
  313. ' this.$assign = function (s) {',
  314. ' return this;',
  315. ' };',
  316. '}, true);',
  317. '']),
  318. LinesToStr([ // $mod.$init
  319. '$impl.p = $mod.$rtti["TAnt<Test1.TBird>"];',
  320. '']),
  321. LinesToStr([ // statements
  322. 'rtl.recNewT($impl, "TBird", function () {',
  323. ' this.b = 0;',
  324. ' this.$eq = function (b) {',
  325. ' return this.b === b.b;',
  326. ' };',
  327. ' this.$assign = function (s) {',
  328. ' this.b = s.b;',
  329. ' return this;',
  330. ' };',
  331. ' var $r = $mod.$rtti.$Record("TBird", {});',
  332. ' $r.addField("b", rtl.word);',
  333. '});',
  334. '$impl.f = $mod.TAnt$G1.$new();',
  335. '$impl.p = null;',
  336. '']));
  337. end;
  338. procedure TTestGenerics.TestGen_Record_Delay_UsedByImplUses;
  339. begin
  340. WithTypeInfo:=true;
  341. StartProgram(true,[supTObject]);
  342. AddModuleWithIntfImplSrc('UnitA.pas',
  343. LinesToStr([
  344. '{$modeswitch AdvancedRecords}',
  345. 'type',
  346. ' generic TBird<T> = record',
  347. ' class var a: T;',
  348. ' end;',
  349. '']),
  350. LinesToStr([
  351. '']));
  352. AddModuleWithIntfImplSrc('UnitB.pas',
  353. LinesToStr([
  354. 'procedure Fly;',
  355. '']),
  356. LinesToStr([
  357. 'uses UnitA;',
  358. 'type',
  359. ' TFox = record',
  360. ' B: word;',
  361. ' end;',
  362. 'procedure Fly;',
  363. 'var Bird: specialize TBird<TFox>;',
  364. 'begin',
  365. ' if typeinfo(Bird)<>nil then ;',
  366. ' Bird.a:=Bird.a;',
  367. 'end;',
  368. '']));
  369. Add([
  370. 'uses UnitB;',
  371. 'begin',
  372. ' Fly;']);
  373. ConvertProgram;
  374. CheckSource('TestGen_Record_Delay_UsedByImplUses',
  375. LinesToStr([ // statements
  376. '$mod.$implcode = function () {',
  377. ' pas.UnitA.TBird$G1.$initSpec();',
  378. '};',
  379. '']),
  380. LinesToStr([ // $mod.$main
  381. 'pas.UnitB.Fly();'
  382. ]));
  383. end;
  384. procedure TTestGenerics.TestGen_ClassEmpty;
  385. begin
  386. StartProgram(false);
  387. Add([
  388. 'type',
  389. ' TObject = class end;',
  390. ' generic TBird<T> = class',
  391. ' end;',
  392. 'var a,b: specialize TBird<word>;',
  393. 'begin',
  394. ' if a=b then ;']);
  395. ConvertProgram;
  396. CheckSource('TestGen_ClassEmpty',
  397. LinesToStr([ // statements
  398. 'rtl.createClass(this, "TObject", null, function () {',
  399. ' this.$init = function () {',
  400. ' };',
  401. ' this.$final = function () {',
  402. ' };',
  403. '});',
  404. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  405. '}, "TBird<System.Word>");',
  406. 'this.a = null;',
  407. 'this.b = null;',
  408. '']),
  409. LinesToStr([ // $mod.$main
  410. 'if ($mod.a === $mod.b) ;'
  411. ]));
  412. end;
  413. procedure TTestGenerics.TestGen_Class_EmptyMethod;
  414. begin
  415. StartProgram(false);
  416. Add([
  417. 'type',
  418. ' TObject = class end;',
  419. ' generic TBird<T> = class',
  420. ' function Fly(w: T): T;',
  421. ' end;',
  422. 'function TBird.Fly(w: T): T;',
  423. 'begin',
  424. 'end;',
  425. 'var a: specialize TBird<word>;',
  426. 'begin',
  427. ' if a.Fly(3)=4 then ;']);
  428. ConvertProgram;
  429. CheckSource('TestGen_Class_EmptyMethod',
  430. LinesToStr([ // statements
  431. 'rtl.createClass(this, "TObject", null, function () {',
  432. ' this.$init = function () {',
  433. ' };',
  434. ' this.$final = function () {',
  435. ' };',
  436. '});',
  437. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  438. ' this.Fly = function (w) {',
  439. ' var Result = 0;',
  440. ' return Result;',
  441. ' };',
  442. '}, "TBird<System.Word>");',
  443. 'this.a = null;',
  444. '']),
  445. LinesToStr([ // $mod.$main
  446. ' if ($mod.a.Fly(3) === 4) ;'
  447. ]));
  448. end;
  449. procedure TTestGenerics.TestGen_Class_TList;
  450. begin
  451. StartProgram(false);
  452. Add([
  453. '{$mode objfpc}',
  454. 'type',
  455. ' TObject = class end;',
  456. ' generic TList<T> = class',
  457. ' strict private',
  458. ' FItems: array of T;',
  459. ' function GetItems(Index: longint): T;',
  460. ' procedure SetItems(Index: longint; Value: T);',
  461. ' public',
  462. ' procedure Alter(w: T);',
  463. ' property Items[Index: longint]: T read GetItems write SetItems; default;',
  464. ' end;',
  465. ' TWordList = specialize TList<word>;',
  466. 'function TList.GetItems(Index: longint): T;',
  467. 'begin',
  468. ' Result:=FItems[Index];',
  469. 'end;',
  470. 'procedure TList.SetItems(Index: longint; Value: T);',
  471. 'begin',
  472. ' FItems[Index]:=Value;',
  473. 'end;',
  474. 'procedure TList.Alter(w: T);',
  475. 'begin',
  476. ' SetLength(FItems,length(FItems)+1);',
  477. ' Insert(w,FItems,2);',
  478. ' Delete(FItems,2,3);',
  479. 'end;',
  480. 'var l: TWordList;',
  481. ' w: word;',
  482. 'begin',
  483. ' l[1]:=w;',
  484. ' w:=l[2];',
  485. '']);
  486. ConvertProgram;
  487. CheckSource('TestGen_Class_TList',
  488. LinesToStr([ // statements
  489. 'rtl.createClass(this, "TObject", null, function () {',
  490. ' this.$init = function () {',
  491. ' };',
  492. ' this.$final = function () {',
  493. ' };',
  494. '});',
  495. 'rtl.createClass(this, "TList$G1", this.TObject, function () {',
  496. ' this.$init = function () {',
  497. ' $mod.TObject.$init.call(this);',
  498. ' this.FItems = [];',
  499. ' };',
  500. ' this.$final = function () {',
  501. ' this.FItems = undefined;',
  502. ' $mod.TObject.$final.call(this);',
  503. ' };',
  504. ' this.GetItems = function (Index) {',
  505. ' var Result = 0;',
  506. ' Result = this.FItems[Index];',
  507. ' return Result;',
  508. ' };',
  509. ' this.SetItems = function (Index, Value) {',
  510. ' this.FItems[Index] = Value;',
  511. ' };',
  512. ' this.Alter = function (w) {',
  513. ' this.FItems = rtl.arraySetLength(this.FItems, 0, rtl.length(this.FItems) + 1);',
  514. ' this.FItems = rtl.arrayInsert(w, this.FItems, 2);',
  515. ' this.FItems.splice(2, 3);',
  516. ' };',
  517. '}, "TList<System.Word>");',
  518. 'this.l = null;',
  519. 'this.w = 0;',
  520. '']),
  521. LinesToStr([ // $mod.$main
  522. '$mod.l.SetItems(1, $mod.w);',
  523. '$mod.w = $mod.l.GetItems(2);',
  524. '']));
  525. end;
  526. procedure TTestGenerics.TestGen_Class_TCustomList;
  527. begin
  528. StartProgram(false);
  529. Add([
  530. '{$mode delphi}',
  531. 'type',
  532. ' TObject = class end;',
  533. ' TCustomList<T> = class',
  534. ' public',
  535. ' function PrepareAddingItem: word; virtual;',
  536. ' end;',
  537. ' TList<T> = class(TCustomList<T>)',
  538. ' public',
  539. ' function Add: word;',
  540. ' end;',
  541. ' TWordList = TList<word>;',
  542. 'function TCustomList<T>.PrepareAddingItem: word;',
  543. 'begin',
  544. 'end;',
  545. 'function TList<T>.Add: word;',
  546. 'begin',
  547. ' Result:=PrepareAddingItem;',
  548. ' Result:=Self.PrepareAddingItem;',
  549. //' with Self do Result:=PrepareAddingItem;',
  550. 'end;',
  551. 'var l: TWordList;',
  552. 'begin',
  553. '']);
  554. ConvertProgram;
  555. CheckSource('TestGen_Class_TCustomList',
  556. LinesToStr([ // statements
  557. 'rtl.createClass(this, "TObject", null, function () {',
  558. ' this.$init = function () {',
  559. ' };',
  560. ' this.$final = function () {',
  561. ' };',
  562. '});',
  563. 'rtl.createClass(this, "TCustomList$G2", this.TObject, function () {',
  564. ' this.PrepareAddingItem = function () {',
  565. ' var Result = 0;',
  566. ' return Result;',
  567. ' };',
  568. '}, "TCustomList<System.Word>");',
  569. 'rtl.createClass(this, "TList$G1", this.TCustomList$G2, function () {',
  570. ' this.Add = function () {',
  571. ' var Result = 0;',
  572. ' Result = this.PrepareAddingItem();',
  573. ' Result = this.PrepareAddingItem();',
  574. ' return Result;',
  575. ' };',
  576. '}, "TList<System.Word>");',
  577. 'this.l = null;',
  578. '']),
  579. LinesToStr([ // $mod.$main
  580. '']));
  581. end;
  582. procedure TTestGenerics.TestGen_ClassAncestor;
  583. begin
  584. StartProgram(false);
  585. Add([
  586. 'type',
  587. ' TObject = class end;',
  588. ' generic TBird<T> = class',
  589. ' end;',
  590. ' generic TEagle<T> = class(specialize TBird<T>)',
  591. ' end;',
  592. 'var a: specialize TEagle<word>;',
  593. 'begin',
  594. '']);
  595. ConvertProgram;
  596. CheckSource('TestGen_ClassAncestor',
  597. LinesToStr([ // statements
  598. 'rtl.createClass(this, "TObject", null, function () {',
  599. ' this.$init = function () {',
  600. ' };',
  601. ' this.$final = function () {',
  602. ' };',
  603. '});',
  604. 'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
  605. '}, "TBird<System.Word>");',
  606. 'rtl.createClass(this, "TEagle$G1", this.TBird$G2, function () {',
  607. '}, "TEagle<System.Word>");',
  608. 'this.a = null;',
  609. '']),
  610. LinesToStr([ // $mod.$main
  611. '']));
  612. end;
  613. procedure TTestGenerics.TestGen_Class_TypeInfo;
  614. begin
  615. WithTypeInfo:=true;
  616. StartProgram(false);
  617. Add([
  618. 'type',
  619. ' TObject = class end;',
  620. ' generic TBird<T> = class',
  621. ' published',
  622. ' m: T;',
  623. ' end;',
  624. ' TEagle = specialize TBird<word>;',
  625. 'var',
  626. ' b: specialize TBird<word>;',
  627. ' p: pointer;',
  628. 'begin',
  629. ' p:=typeinfo(TEagle);',
  630. ' p:=typeinfo(b);',
  631. '']);
  632. ConvertProgram;
  633. CheckSource('TestGen_Class_TypeInfo',
  634. LinesToStr([ // statements
  635. '$mod.$rtti.$Class("TBird<System.Word>");',
  636. 'rtl.createClass(this, "TObject", null, function () {',
  637. ' this.$init = function () {',
  638. ' };',
  639. ' this.$final = function () {',
  640. ' };',
  641. '});',
  642. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  643. ' this.$init = function () {',
  644. ' $mod.TObject.$init.call(this);',
  645. ' this.m = 0;',
  646. ' };',
  647. ' var $r = this.$rtti;',
  648. ' $r.addField("m", rtl.word);',
  649. '}, "TBird<System.Word>");',
  650. 'this.b = null;',
  651. 'this.p = null;',
  652. '']),
  653. LinesToStr([ // $mod.$main
  654. '$mod.p = $mod.$rtti["TBird<System.Word>"];',
  655. '$mod.p = $mod.b.$rtti;',
  656. '']));
  657. end;
  658. procedure TTestGenerics.TestGen_Class_TypeOverload;
  659. begin
  660. exit;// ToDo
  661. StartProgram(false);
  662. Add([
  663. '{$mode delphi}',
  664. 'type',
  665. ' TObject = class end;',
  666. ' TBird = word;',
  667. ' TBird<T> = class',
  668. ' m: T;',
  669. ' end;',
  670. ' TEagle = TBird<word>;',
  671. 'var',
  672. ' b: TBird<word>;',
  673. ' e: TEagle;',
  674. 'begin',
  675. '']);
  676. ConvertProgram;
  677. CheckSource('TestGen_Class_TypeOverload',
  678. LinesToStr([ // statements
  679. 'rtl.createClass(this, "TObject", null, function () {',
  680. ' this.$init = function () {',
  681. ' };',
  682. ' this.$final = function () {',
  683. ' };',
  684. '});',
  685. '']),
  686. LinesToStr([ // $mod.$main
  687. '']));
  688. end;
  689. procedure TTestGenerics.TestGen_Class_ClassProperty;
  690. begin
  691. StartProgram(false);
  692. Add([
  693. '{$mode delphi}',
  694. 'type',
  695. ' TObject = class end;',
  696. ' TBird<T> = class',
  697. ' private',
  698. ' class var fSize: T;',
  699. ' public',
  700. ' class property Size: T read fSize write fSize;',
  701. ' end;',
  702. ' TEagle = TBird<word>;',
  703. 'begin',
  704. ' TBird<word>.Size:=3+TBird<word>.Size;',
  705. '']);
  706. ConvertProgram;
  707. CheckSource('TestGen_Class_ClassProperty',
  708. LinesToStr([ // statements
  709. 'rtl.createClass(this, "TObject", null, function () {',
  710. ' this.$init = function () {',
  711. ' };',
  712. ' this.$final = function () {',
  713. ' };',
  714. '});',
  715. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  716. ' this.fSize = 0;',
  717. '}, "TBird<System.Word>");',
  718. '']),
  719. LinesToStr([ // $mod.$main
  720. '$mod.TBird$G1.fSize = 3 + $mod.TBird$G1.fSize;',
  721. '']));
  722. end;
  723. procedure TTestGenerics.TestGen_Class_ClassProc;
  724. begin
  725. StartProgram(false);
  726. Add([
  727. 'type',
  728. ' TObject = class end;',
  729. ' generic TPoint<T> = class',
  730. ' class var x: T;',
  731. ' class procedure Fly; static;',
  732. ' class procedure Run;',
  733. ' end;',
  734. 'class procedure Tpoint.Fly;',
  735. 'begin',
  736. ' x:=x+3;',
  737. ' tpoint.x:=tpoint.x+4;',
  738. ' Fly;',
  739. ' tpoint.Fly;',
  740. ' Run;',
  741. ' tpoint.Run;',
  742. 'end;',
  743. 'class procedure TPoint.Run;',
  744. 'begin',
  745. ' x:=x+5;',
  746. ' tpoint.x:=tpoint.x+6;',
  747. ' Fly;',
  748. ' tpoint.Fly;',
  749. ' Run;',
  750. ' tpoint.Run;',
  751. 'end;',
  752. 'var p: specialize TPoint<word>;',
  753. 'begin',
  754. '']);
  755. ConvertProgram;
  756. CheckSource('TestGen_Class_ClassProc',
  757. LinesToStr([ // statements
  758. 'rtl.createClass(this, "TObject", null, function () {',
  759. ' this.$init = function () {',
  760. ' };',
  761. ' this.$final = function () {',
  762. ' };',
  763. '});',
  764. 'rtl.createClass(this, "TPoint$G1", this.TObject, function () {',
  765. ' this.x = 0;',
  766. ' this.Fly = function () {',
  767. ' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 3;',
  768. ' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 4;',
  769. ' $mod.TPoint$G1.Fly();',
  770. ' $mod.TPoint$G1.Fly();',
  771. ' $mod.TPoint$G1.Run();',
  772. ' $mod.TPoint$G1.Run();',
  773. ' };',
  774. ' this.Run = function () {',
  775. ' $mod.TPoint$G1.x = this.x + 5;',
  776. ' $mod.TPoint$G1.x = $mod.TPoint$G1.x + 6;',
  777. ' this.Fly();',
  778. ' this.Fly();',
  779. ' this.Run();',
  780. ' $mod.TPoint$G1.Run();',
  781. ' };',
  782. '}, "TPoint<System.Word>");',
  783. 'this.p = null;',
  784. '']),
  785. LinesToStr([ // $mod.$main
  786. '']));
  787. end;
  788. procedure TTestGenerics.TestGen_Class_ClassConstructor;
  789. begin
  790. StartProgram(false);
  791. Add([
  792. 'type',
  793. ' TObject = class end;',
  794. ' generic TPoint<T> = class',
  795. ' class var x: T;',
  796. ' class procedure Fly; static;',
  797. ' class constructor Init;',
  798. ' end;',
  799. 'var count: word;',
  800. 'class procedure Tpoint.Fly;',
  801. 'begin',
  802. 'end;',
  803. 'class constructor tpoint.init;',
  804. 'begin',
  805. ' count:=count+1;',
  806. ' x:=3;',
  807. ' tpoint.x:=4;',
  808. ' fly;',
  809. ' tpoint.fly;',
  810. 'end;',
  811. 'var',
  812. ' r: specialize TPoint<word>;',
  813. ' s: specialize TPoint<smallint>;',
  814. 'begin',
  815. ' r.x:=10;',
  816. '']);
  817. ConvertProgram;
  818. CheckSource('TestGen_Class_ClassConstructor',
  819. LinesToStr([ // statements
  820. 'rtl.createClass(this, "TObject", null, function () {',
  821. ' this.$init = function () {',
  822. ' };',
  823. ' this.$final = function () {',
  824. ' };',
  825. '});',
  826. 'this.count = 0;',
  827. 'rtl.createClass(this, "TPoint$G1", this.TObject, function () {',
  828. ' this.x = 0;',
  829. ' this.Fly = function () {',
  830. ' };',
  831. '}, "TPoint<System.Word>");',
  832. 'this.r = null;',
  833. 'rtl.createClass(this, "TPoint$G2", this.TObject, function () {',
  834. ' this.x = 0;',
  835. ' this.Fly = function () {',
  836. ' };',
  837. '}, "TPoint<System.SmallInt>");',
  838. 'this.s = null;',
  839. '']),
  840. LinesToStr([ // $mod.$main
  841. '(function () {',
  842. ' $mod.count = $mod.count + 1;',
  843. ' $mod.TPoint$G1.x = 3;',
  844. ' $mod.TPoint$G1.x = 4;',
  845. ' $mod.TPoint$G1.Fly();',
  846. ' $mod.TPoint$G1.Fly();',
  847. '})();',
  848. '(function () {',
  849. ' $mod.count = $mod.count + 1;',
  850. ' $mod.TPoint$G2.x = 3;',
  851. ' $mod.TPoint$G2.x = 4;',
  852. ' $mod.TPoint$G2.Fly();',
  853. ' $mod.TPoint$G2.Fly();',
  854. '})();',
  855. '$mod.TPoint$G1.x = 10;',
  856. '']));
  857. end;
  858. procedure TTestGenerics.TestGen_Class_TypeCastSpecializesWarn;
  859. begin
  860. StartProgram(false);
  861. Add([
  862. '{$mode delphi}',
  863. 'type',
  864. ' TObject = class end;',
  865. ' TBird<T> = class F: T; end;',
  866. ' TBirdWord = TBird<Word>;',
  867. ' TBirdChar = TBird<Char>;',
  868. 'var',
  869. ' w: TBirdWord;',
  870. ' c: TBirdChar;',
  871. 'begin',
  872. ' w:=TBirdWord(c);',
  873. '']);
  874. ConvertProgram;
  875. CheckSource('TestGen_Class_TypeCastSpecializesWarn',
  876. LinesToStr([ // statements
  877. 'rtl.createClass(this, "TObject", null, function () {',
  878. ' this.$init = function () {',
  879. ' };',
  880. ' this.$final = function () {',
  881. ' };',
  882. '});',
  883. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  884. ' this.$init = function () {',
  885. ' $mod.TObject.$init.call(this);',
  886. ' this.F = 0;',
  887. ' };',
  888. '}, "TBird<System.Word>");',
  889. 'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
  890. ' this.$init = function () {',
  891. ' $mod.TObject.$init.call(this);',
  892. ' this.F = "";',
  893. ' };',
  894. '}, "TBird<System.Char>");',
  895. 'this.w = null;',
  896. 'this.c = null;',
  897. '']),
  898. LinesToStr([ // $mod.$main
  899. '$mod.w = $mod.c;',
  900. '']));
  901. CheckHint(mtWarning,nClassTypesAreNotRelatedXY,'Class types "TBird<System.Char>" and "TBird<System.Word>" are not related');
  902. CheckResolverUnexpectedHints();
  903. end;
  904. procedure TTestGenerics.TestGen_Class_TypeCastSpecializesJSValueNoWarn;
  905. begin
  906. StartProgram(false);
  907. Add([
  908. '{$mode delphi}',
  909. 'type',
  910. ' TObject = class end;',
  911. ' TBird<T> = class F: T; end;',
  912. ' TBirdWord = TBird<Word>;',
  913. ' TBirdAny = TBird<JSValue>;',
  914. 'var',
  915. ' w: TBirdWord;',
  916. ' a: TBirdAny;',
  917. 'begin',
  918. ' w:=TBirdWord(a);',
  919. ' a:=TBirdAny(w);',
  920. '']);
  921. ConvertProgram;
  922. CheckSource('TestGen_Class_TypeCastSpecializesJSValueNoWarn',
  923. LinesToStr([ // statements
  924. 'rtl.createClass(this, "TObject", null, function () {',
  925. ' this.$init = function () {',
  926. ' };',
  927. ' this.$final = function () {',
  928. ' };',
  929. '});',
  930. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  931. ' this.$init = function () {',
  932. ' $mod.TObject.$init.call(this);',
  933. ' this.F = 0;',
  934. ' };',
  935. '}, "TBird<System.Word>");',
  936. 'rtl.createClass(this, "TBird$G2", this.TObject, function () {',
  937. ' this.$init = function () {',
  938. ' $mod.TObject.$init.call(this);',
  939. ' this.F = undefined;',
  940. ' };',
  941. '}, "TBird<System.JSValue>");',
  942. 'this.w = null;',
  943. 'this.a = null;',
  944. '']),
  945. LinesToStr([ // $mod.$main
  946. '$mod.w = $mod.a;',
  947. '$mod.a = $mod.w;',
  948. '']));
  949. CheckResolverUnexpectedHints();
  950. end;
  951. procedure TTestGenerics.TestGen_Class_OverloadsInUnit;
  952. begin
  953. StartProgram(true,[supTObject]);
  954. AddModuleWithIntfImplSrc('UnitA.pas',
  955. LinesToStr([
  956. 'type',
  957. ' generic TBird<T> = class',
  958. ' const c = 13;',
  959. ' constructor Create(w: T);',
  960. ' constructor Create(b: boolean);',
  961. ' end;',
  962. '']),
  963. LinesToStr([
  964. 'constructor TBird.Create(w: T);',
  965. 'const c = 14;',
  966. 'begin',
  967. 'end;',
  968. 'constructor TBird.Create(b: boolean);',
  969. 'const c = 15;',
  970. 'begin',
  971. 'end;',
  972. '']));
  973. Add([
  974. 'uses UnitA;',
  975. 'type',
  976. ' TWordBird = specialize TBird<word>;',
  977. ' TDoubleBird = specialize TBird<double>;',
  978. 'var',
  979. ' wb: TWordBird;',
  980. ' db: TDoubleBird;',
  981. 'begin',
  982. ' wb:=TWordBird.Create(3);',
  983. ' wb:=TWordBird.Create(true);',
  984. ' db:=TDoubleBird.Create(1.3);',
  985. ' db:=TDoubleBird.Create(true);',
  986. '']);
  987. ConvertProgram;
  988. CheckUnit('UnitA.pas',
  989. LinesToStr([ // statements
  990. 'rtl.module("UnitA", ["system"], function () {',
  991. ' var $mod = this;',
  992. ' rtl.createClass(this, "TBird$G1", pas.system.TObject, function () {',
  993. ' this.c = 13;',
  994. ' var c$1 = 14;',
  995. ' this.Create$1 = function (w) {',
  996. ' return this;',
  997. ' };',
  998. ' var c$2 = 15;',
  999. ' this.Create$2 = function (b) {',
  1000. ' return this;',
  1001. ' };',
  1002. ' }, "TBird<System.Word>");',
  1003. ' rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
  1004. ' this.c = 13;',
  1005. ' var c$1 = 14;',
  1006. ' this.Create$1 = function (w) {',
  1007. ' return this;',
  1008. ' };',
  1009. ' var c$2 = 15;',
  1010. ' this.Create$2 = function (b) {',
  1011. ' return this;',
  1012. ' };',
  1013. ' }, "TBird<System.Double>");',
  1014. '});',
  1015. '']));
  1016. CheckSource('TestGen_Class_OverloadsInUnit',
  1017. LinesToStr([ // statements
  1018. 'this.wb = null;',
  1019. 'this.db = null;',
  1020. '']),
  1021. LinesToStr([ // $mod.$main
  1022. '$mod.wb = pas.UnitA.TBird$G1.$create("Create$1", [3]);',
  1023. '$mod.wb = pas.UnitA.TBird$G1.$create("Create$2", [true]);',
  1024. '$mod.db = pas.UnitA.TBird$G2.$create("Create$1", [1.3]);',
  1025. '$mod.db = pas.UnitA.TBird$G2.$create("Create$2", [true]);',
  1026. '']));
  1027. end;
  1028. procedure TTestGenerics.TestGen_ClassForward_CircleRTTI;
  1029. begin
  1030. WithTypeInfo:=true;
  1031. StartProgram(false);
  1032. Add([
  1033. '{$mode objfpc}',
  1034. 'type',
  1035. ' TObject = class end;',
  1036. ' {$M+}',
  1037. ' TPersistent = class end;',
  1038. ' {$M-}',
  1039. ' generic TAnt<T> = class;',
  1040. ' generic TFish<U> = class(TPersistent)',
  1041. ' private type AliasU = U;',
  1042. ' published',
  1043. ' a: specialize TAnt<AliasU>;',
  1044. ' end;',
  1045. ' generic TAnt<T> = class(TPersistent)',
  1046. ' private type AliasT = T;',
  1047. ' published',
  1048. ' f: specialize TFish<AliasT>;',
  1049. ' end;',
  1050. 'var',
  1051. ' WordFish: specialize TFish<word>;',
  1052. ' p: pointer;',
  1053. 'begin',
  1054. ' p:=typeinfo(specialize TAnt<word>);',
  1055. ' p:=typeinfo(specialize TFish<word>);',
  1056. '']);
  1057. ConvertProgram;
  1058. CheckSource('TestGen_ClassForward_CircleRTTI',
  1059. LinesToStr([ // statements
  1060. '$mod.$rtti.$Class("TAnt<System.Word>");',
  1061. '$mod.$rtti.$Class("TFish<System.Word>");',
  1062. 'rtl.createClass(this, "TObject", null, function () {',
  1063. ' this.$init = function () {',
  1064. ' };',
  1065. ' this.$final = function () {',
  1066. ' };',
  1067. '});',
  1068. 'rtl.createClass(this, "TPersistent", this.TObject, function () {',
  1069. '});',
  1070. 'rtl.createClass(this, "TAnt$G2", this.TPersistent, function () {',
  1071. ' this.$init = function () {',
  1072. ' $mod.TPersistent.$init.call(this);',
  1073. ' this.f = null;',
  1074. ' };',
  1075. ' this.$final = function () {',
  1076. ' this.f = undefined;',
  1077. ' $mod.TPersistent.$final.call(this);',
  1078. ' };',
  1079. ' var $r = this.$rtti;',
  1080. ' $r.addField("f", $mod.$rtti["TFish<System.Word>"]);',
  1081. '}, "TAnt<System.Word>");',
  1082. 'rtl.createClass(this, "TFish$G2", this.TPersistent, function () {',
  1083. ' this.$init = function () {',
  1084. ' $mod.TPersistent.$init.call(this);',
  1085. ' this.a = null;',
  1086. ' };',
  1087. ' this.$final = function () {',
  1088. ' this.a = undefined;',
  1089. ' $mod.TPersistent.$final.call(this);',
  1090. ' };',
  1091. ' var $r = this.$rtti;',
  1092. ' $r.addField("a", $mod.$rtti["TAnt<System.Word>"]);',
  1093. '}, "TFish<System.Word>");',
  1094. 'this.WordFish = null;',
  1095. 'this.p = null;',
  1096. '']),
  1097. LinesToStr([ // $mod.$main
  1098. '$mod.p = $mod.$rtti["TAnt<System.Word>"];',
  1099. '$mod.p = $mod.$rtti["TFish<System.Word>"];',
  1100. '']));
  1101. end;
  1102. procedure TTestGenerics.TestGen_Class_Nested_RTTI;
  1103. begin
  1104. WithTypeInfo:=true;
  1105. StartProgram(true,[supTObject]);
  1106. AddModuleWithIntfImplSrc('UnitA.pas',
  1107. LinesToStr([
  1108. 'type',
  1109. ' generic TAnt<T> = class',
  1110. ' type',
  1111. ' TLeg = class',
  1112. ' published',
  1113. ' Size: T;',
  1114. ' end;',
  1115. ' end;',
  1116. ' TBoolAnt = specialize TAnt<boolean>;',
  1117. '']),
  1118. LinesToStr([
  1119. '']));
  1120. Add([
  1121. 'uses UnitA;',
  1122. 'var',
  1123. ' BoolLeg: TBoolAnt.TLeg;',
  1124. 'begin',
  1125. ' if typeinfo(TBoolAnt.TLeg)=nil then ;',
  1126. '']);
  1127. ConvertProgram;
  1128. CheckUnit('UnitA.pas',
  1129. LinesToStr([ // statements
  1130. 'rtl.module("UnitA", ["system"], function () {',
  1131. ' var $mod = this;',
  1132. ' $mod.$rtti.$Class("TAnt<System.Boolean>");',
  1133. ' rtl.createClass(this, "TAnt$G1", pas.system.TObject, function () {',
  1134. ' rtl.createClass(this, "TLeg", pas.system.TObject, function () {',
  1135. ' this.$init = function () {',
  1136. ' pas.system.TObject.$init.call(this);',
  1137. ' this.Size = false;',
  1138. ' };',
  1139. ' var $r = this.$rtti;',
  1140. ' $r.addField("Size", rtl.boolean);',
  1141. ' }, "TAnt<System.Boolean>.TLeg");',
  1142. ' }, "TAnt<System.Boolean>");',
  1143. '});']));
  1144. CheckSource('TestGen_Class_Nested_RTTI',
  1145. LinesToStr([ // statements
  1146. 'this.BoolLeg = null;',
  1147. '']),
  1148. LinesToStr([ // $mod.$main
  1149. 'if (pas.UnitA.$rtti["TAnt<System.Boolean>.TLeg"] === null) ;',
  1150. '']));
  1151. end;
  1152. procedure TTestGenerics.TestGen_Class_ClassVarRecord_UnitImpl;
  1153. begin
  1154. StartProgram(true,[supTObject]);
  1155. AddModuleWithIntfImplSrc('UnitA.pas',
  1156. LinesToStr([
  1157. 'type',
  1158. ' generic TAnt<T> = class',
  1159. ' public',
  1160. ' class var x: T;',
  1161. ' class var a: array[1..2] of T;',
  1162. ' end;',
  1163. '']),
  1164. LinesToStr([
  1165. 'type',
  1166. ' TBird = record',
  1167. ' b: word;',
  1168. ' end;',
  1169. 'var f: specialize TAnt<TBird>;',
  1170. 'begin',
  1171. ' f.x.b:=f.x.b+10;',
  1172. '']));
  1173. Add([
  1174. 'uses UnitA;',
  1175. 'begin',
  1176. 'end.']);
  1177. ConvertProgram;
  1178. CheckUnit('UnitA.pas',
  1179. LinesToStr([ // statements
  1180. 'rtl.module("UnitA", ["system"], function () {',
  1181. ' var $mod = this;',
  1182. ' var $impl = $mod.$impl;',
  1183. ' rtl.createClass(this, "TAnt$G1", pas.system.TObject, function () {',
  1184. ' this.$initSpec = function () {',
  1185. ' this.x = $impl.TBird.$new();',
  1186. ' this.a = rtl.arraySetLength(null, $impl.TBird, 2);',
  1187. ' };',
  1188. ' this.a$a$clone = function (a) {',
  1189. ' var r = [];',
  1190. ' for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
  1191. ' return r;',
  1192. ' };',
  1193. ' }, "TAnt<UnitA.TBird>");',
  1194. ' $mod.$implcode = function () {',
  1195. ' rtl.recNewT($impl, "TBird", function () {',
  1196. ' this.b = 0;',
  1197. ' this.$eq = function (b) {',
  1198. ' return this.b === b.b;',
  1199. ' };',
  1200. ' this.$assign = function (s) {',
  1201. ' this.b = s.b;',
  1202. ' return this;',
  1203. ' };',
  1204. ' });',
  1205. ' $impl.f = null;',
  1206. ' };',
  1207. ' $mod.$init = function () {',
  1208. ' $impl.f.x.b = $impl.f.x.b + 10;',
  1209. ' };',
  1210. '}, []);',
  1211. '']));
  1212. CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
  1213. LinesToStr([ // statements
  1214. '$mod.$implcode = function () {',
  1215. ' pas.UnitA.TAnt$G1.$initSpec();',
  1216. '};',
  1217. '']),
  1218. LinesToStr([ // $mod.$main
  1219. '']));
  1220. end;
  1221. procedure TTestGenerics.TestGen_ExtClass_VarArgsOfType;
  1222. begin
  1223. StartProgram(false);
  1224. Add([
  1225. '{$mode objfpc}',
  1226. '{$modeswitch externalclass}',
  1227. 'type',
  1228. ' TJSObject = class external name ''Object''',
  1229. ' end;',
  1230. ' generic TGJSSet<T> = class external name ''Set''',
  1231. ' constructor new(aElement1: T); varargs of T; overload;',
  1232. ' function bind(thisArg: TJSObject): T; varargs of T;',
  1233. ' end;',
  1234. ' TJSWordSet = specialize TGJSSet<word>;',
  1235. 'var',
  1236. ' s: TJSWordSet;',
  1237. ' w: word;',
  1238. 'begin',
  1239. ' s:=TJSWordSet.new(3);',
  1240. ' s:=TJSWordSet.new(3,5);',
  1241. ' w:=s.bind(nil);',
  1242. ' w:=s.bind(nil,6);',
  1243. ' w:=s.bind(nil,7,8);',
  1244. '']);
  1245. ConvertProgram;
  1246. CheckSource('TestGen_ExtClass_VarArgsOfType',
  1247. LinesToStr([ // statements
  1248. 'this.s = null;',
  1249. 'this.w = 0;',
  1250. '']),
  1251. LinesToStr([ // $mod.$main
  1252. '$mod.s = new Set(3);',
  1253. '$mod.s = new Set(3, 5);',
  1254. '$mod.w = $mod.s.bind(null);',
  1255. '$mod.w = $mod.s.bind(null, 6);',
  1256. '$mod.w = $mod.s.bind(null, 7, 8);',
  1257. '']));
  1258. end;
  1259. procedure TTestGenerics.TestGen_ExtClass_Array;
  1260. begin
  1261. StartProgram(false);
  1262. Add([
  1263. '{$mode delphi}',
  1264. '{$ModeSwitch externalclass}',
  1265. 'type',
  1266. ' NativeInt = longint;',
  1267. ' TJSGenArray<T> = Class external name ''Array''',
  1268. ' private',
  1269. ' function GetElements(Index: NativeInt): T; external name ''[]'';',
  1270. ' procedure SetElements(Index: NativeInt; const AValue: T); external name ''[]'';',
  1271. ' public',
  1272. ' type TSelfType = TJSGenArray<T>;',
  1273. ' public',
  1274. ' FLength : NativeInt; external name ''length'';',
  1275. ' constructor new; overload;',
  1276. ' constructor new(aLength : NativeInt); overload;',
  1277. ' class function _of() : TSelfType; varargs; external name ''of'';',
  1278. ' function fill(aValue : T) : TSelfType; overload;',
  1279. ' function fill(aValue : T; aStartIndex : NativeInt) : TSelfType; overload;',
  1280. ' function fill(aValue : T; aStartIndex,aEndIndex : NativeInt) : TSelfType; overload;',
  1281. ' property Length : NativeInt Read FLength Write FLength;',
  1282. ' property Elements[Index: NativeInt]: T read GetElements write SetElements; default;',
  1283. ' end;',
  1284. ' TJSWordArray = TJSGenArray<word>;',
  1285. 'var',
  1286. ' wa: TJSWordArray;',
  1287. ' w: word;',
  1288. 'begin',
  1289. ' wa:=TJSWordArray.new;',
  1290. ' wa:=TJSWordArray.new(3);',
  1291. ' wa:=TJSWordArray._of(4,5);',
  1292. ' wa:=wa.fill(7);',
  1293. ' wa:=wa.fill(7,8,9);',
  1294. ' w:=wa.length;',
  1295. ' wa.length:=10;',
  1296. ' wa[11]:=w;',
  1297. ' w:=wa[12];',
  1298. '']);
  1299. ConvertProgram;
  1300. CheckSource('TestGen_ExtClass_Array',
  1301. LinesToStr([ // statements
  1302. 'this.wa = null;',
  1303. 'this.w = 0;',
  1304. '']),
  1305. LinesToStr([ // $mod.$main
  1306. '$mod.wa = new Array();',
  1307. '$mod.wa = new Array(3);',
  1308. '$mod.wa = Array.of(4, 5);',
  1309. '$mod.wa = $mod.wa.fill(7);',
  1310. '$mod.wa = $mod.wa.fill(7, 8, 9);',
  1311. '$mod.w = $mod.wa.length;',
  1312. '$mod.wa.length = 10;',
  1313. '$mod.wa[11] = $mod.w;',
  1314. '$mod.w = $mod.wa[12];',
  1315. '']));
  1316. end;
  1317. procedure TTestGenerics.TestGen_ExtClass_GenJSValueAssign;
  1318. begin
  1319. StartProgram(false);
  1320. Add([
  1321. '{$mode delphi}',
  1322. '{$modeswitch externalclass}',
  1323. 'type',
  1324. ' TExt<T> = class external name ''Ext''',
  1325. ' F: T;',
  1326. ' end;',
  1327. ' TExtWord = TExt<Word>;',
  1328. ' TExtAny = TExt<JSValue>;',
  1329. 'procedure Run(e: TExtAny);',
  1330. 'begin end;',
  1331. 'var',
  1332. ' w: TExtWord;',
  1333. ' a: TExtAny;',
  1334. 'begin',
  1335. ' a:=w;',
  1336. ' Run(w);',
  1337. '']);
  1338. ConvertProgram;
  1339. CheckSource('TestGen_ExtClass_GenJSValueAssign',
  1340. LinesToStr([ // statements
  1341. 'this.Run = function (e) {',
  1342. '};',
  1343. 'this.w = null;',
  1344. 'this.a = null;',
  1345. '']),
  1346. LinesToStr([ // $mod.$main
  1347. '$mod.a = $mod.w;',
  1348. '$mod.Run($mod.w);',
  1349. '']));
  1350. CheckResolverUnexpectedHints();
  1351. end;
  1352. procedure TTestGenerics.TestGen_ExtClass_AliasMemberType;
  1353. begin
  1354. StartProgram(false);
  1355. Add([
  1356. '{$mode objfpc}',
  1357. '{$modeswitch externalclass}',
  1358. 'type',
  1359. ' generic TExt<T> = class external name ''Ext''',
  1360. ' public type TRun = reference to function(a: T): T;',
  1361. ' end;',
  1362. ' TExtWord = specialize TExt<word>;',
  1363. ' TExtWordRun = TExtWord.TRun;',
  1364. 'begin',
  1365. '']);
  1366. ConvertProgram;
  1367. CheckSource('TestGen_ExtClass_AliasMemberType',
  1368. LinesToStr([ // statements
  1369. '']),
  1370. LinesToStr([ // $mod.$main
  1371. '']));
  1372. end;
  1373. procedure TTestGenerics.TestGen_ExtClass_RTTI;
  1374. begin
  1375. WithTypeInfo:=true;
  1376. StartProgram(false);
  1377. Add([
  1378. '{$mode objfpc}',
  1379. '{$modeswitch externalclass}',
  1380. 'type',
  1381. ' generic TGJSSET<T> = class external name ''SET''',
  1382. ' A: T;',
  1383. ' end;',
  1384. ' TJSSet = specialize TGJSSET<JSValue>;',
  1385. ' TJSSetEventProc = reference to procedure(value : JSValue; key: NativeInt; set_: TJSSet);',
  1386. 'var p: Pointer;',
  1387. 'begin',
  1388. ' p:=typeinfo(TJSSetEventProc);',
  1389. '']);
  1390. ConvertProgram;
  1391. CheckSource('TestGen_ExtClass_RTTI',
  1392. LinesToStr([ // statements
  1393. 'this.$rtti.$ExtClass("TGJSSET<System.JSValue>", {',
  1394. ' jsclass: "SET"',
  1395. '});',
  1396. 'this.$rtti.$RefToProcVar("TJSSetEventProc", {',
  1397. ' procsig: rtl.newTIProcSig([["value", rtl.jsvalue], ["key", rtl.nativeint], ["set_", this.$rtti["TGJSSET<System.JSValue>"]]])',
  1398. '});',
  1399. 'this.p = null;',
  1400. '']),
  1401. LinesToStr([ // $mod.$main
  1402. '$mod.p = $mod.$rtti["TJSSetEventProc"];',
  1403. '']));
  1404. end;
  1405. procedure TTestGenerics.TestGen_ExtClass_UnitImplRec;
  1406. begin
  1407. WithTypeInfo:=true;
  1408. StartProgram(true,[supTObject]);
  1409. AddModuleWithIntfImplSrc('UnitA.pas',
  1410. LinesToStr([
  1411. '{$mode objfpc}',
  1412. '{$modeswitch externalclass}',
  1413. 'type',
  1414. ' generic TAnt<T> = class external name ''SET''',
  1415. ' x: T;',
  1416. ' end;',
  1417. '']),
  1418. LinesToStr([
  1419. 'type',
  1420. ' TBird = record',
  1421. ' b: word;',
  1422. ' end;',
  1423. 'var',
  1424. ' f: specialize TAnt<TBird>;',
  1425. 'begin',
  1426. ' f.x.b:=f.x.b+10;',
  1427. '']));
  1428. Add([
  1429. 'uses UnitA;',
  1430. 'begin',
  1431. 'end.']);
  1432. ConvertProgram;
  1433. CheckUnit('UnitA.pas',
  1434. LinesToStr([ // statements
  1435. 'rtl.module("UnitA", ["system"], function () {',
  1436. ' var $mod = this;',
  1437. ' var $impl = $mod.$impl;',
  1438. ' this.$rtti.$ExtClass("TAnt<UnitA.TBird>", {',
  1439. ' jsclass: "SET"',
  1440. ' });',
  1441. ' $mod.$implcode = function () {',
  1442. ' rtl.recNewT($impl, "TBird", function () {',
  1443. ' this.b = 0;',
  1444. ' this.$eq = function (b) {',
  1445. ' return this.b === b.b;',
  1446. ' };',
  1447. ' this.$assign = function (s) {',
  1448. ' this.b = s.b;',
  1449. ' return this;',
  1450. ' };',
  1451. ' var $r = $mod.$rtti.$Record("TBird", {});',
  1452. ' $r.addField("b", rtl.word);',
  1453. ' });',
  1454. ' $impl.f = null;',
  1455. ' };',
  1456. ' $mod.$init = function () {',
  1457. ' $impl.f.x.b = $impl.f.x.b + 10;',
  1458. ' };',
  1459. '}, []);']));
  1460. CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
  1461. LinesToStr([ // statements
  1462. '']),
  1463. LinesToStr([ // $mod.$main
  1464. '']));
  1465. end;
  1466. procedure TTestGenerics.TestGen_ClassInterface_Corba;
  1467. begin
  1468. StartProgram(false);
  1469. Add([
  1470. '{$interfaces corba}',
  1471. 'type',
  1472. ' IUnknown = interface;',
  1473. ' IUnknown = interface',
  1474. ' [''{00000000-0000-0000-C000-000000000046}'']',
  1475. ' end;',
  1476. ' IInterface = IUnknown;',
  1477. ' generic IBird<T> = interface(IInterface)',
  1478. ' function GetSize: T;',
  1479. ' procedure SetSize(i: T);',
  1480. ' property Size: T read GetSize write SetSize;',
  1481. ' procedure DoIt(i: T);',
  1482. ' end;',
  1483. ' TObject = class',
  1484. ' end;',
  1485. ' generic TBird<T> = class(TObject,specialize IBird<T>)',
  1486. ' function GetSize: T; virtual; abstract;',
  1487. ' procedure SetSize(i: T); virtual; abstract;',
  1488. ' procedure DoIt(i: T); virtual; abstract;',
  1489. ' end;',
  1490. ' IWordBird = specialize IBird<Word>;',
  1491. ' TWordBird = specialize TBird<Word>;',
  1492. 'var',
  1493. ' BirdIntf: IWordBird;',
  1494. 'begin',
  1495. ' BirdIntf.Size:=BirdIntf.Size;',
  1496. '']);
  1497. ConvertProgram;
  1498. CheckSource('TestGen_ClassInterface_Corba',
  1499. LinesToStr([ // statements
  1500. 'rtl.createInterface(this, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
  1501. 'rtl.createClass(this, "TObject", null, function () {',
  1502. ' this.$init = function () {',
  1503. ' };',
  1504. ' this.$final = function () {',
  1505. ' };',
  1506. '});',
  1507. 'rtl.createInterface(',
  1508. ' this,',
  1509. ' "IBird$G2",',
  1510. ' "{33AB51C6-6240-3BDF-B4B0-D48A593EAB0A}",',
  1511. ' ["GetSize", "SetSize", "DoIt"],',
  1512. ' this.IUnknown,',
  1513. ' "IBird<System.Word>"',
  1514. ');',
  1515. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  1516. ' rtl.addIntf(this, $mod.IBird$G2);',
  1517. '}, "TBird<System.Word>");',
  1518. 'this.BirdIntf = null;',
  1519. '']),
  1520. LinesToStr([ // $mod.$main
  1521. '$mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
  1522. '']));
  1523. end;
  1524. procedure TTestGenerics.TestGen_ClassInterface_InterfacedObject;
  1525. begin
  1526. StartProgram(true,[supTInterfacedObject]);
  1527. Add([
  1528. '{$mode delphi}',
  1529. 'type',
  1530. ' IComparer<T> = interface [''{505778ED-F783-4456-9691-32F419CC5E18}'']',
  1531. ' function Compare(const Left, Right: T): Integer; overload;',
  1532. ' end;',
  1533. ' TComparer<T> = class(TInterfacedObject, IComparer<T>)',
  1534. ' function Compare(const Left, Right: T): Integer;',
  1535. ' end;',
  1536. 'function TComparer<T>.Compare(const Left, Right: T): Integer; begin end;',
  1537. 'var',
  1538. ' aComparer : IComparer<Integer>;',
  1539. 'begin',
  1540. ' aComparer:=TComparer<Integer>.Create;',
  1541. '']);
  1542. ConvertProgram;
  1543. CheckSource('TestGen_ClassInterface_InterfacedObject',
  1544. LinesToStr([ // statements
  1545. 'rtl.createInterface(',
  1546. ' this,',
  1547. ' "IComparer$G2",',
  1548. ' "{505778ED-F783-4456-9691-32F419CC5E18}",',
  1549. ' ["Compare"],',
  1550. ' pas.system.IUnknown,',
  1551. ' "IComparer<System.Longint>"',
  1552. ');',
  1553. 'this.aComparer = null;',
  1554. 'rtl.createClass(this, "TComparer$G1", pas.system.TInterfacedObject, function () {',
  1555. ' this.Compare = function (Left, Right) {',
  1556. ' var Result = 0;',
  1557. ' return Result;',
  1558. ' };',
  1559. ' rtl.addIntf(this, $mod.IComparer$G2);',
  1560. ' rtl.addIntf(this, pas.system.IUnknown);',
  1561. '}, "TComparer<System.Longint>");',
  1562. '']),
  1563. LinesToStr([ // $mod.$main
  1564. 'rtl.setIntfP($mod, "aComparer", rtl.queryIntfT($mod.TComparer$G1.$create("Create"), $mod.IComparer$G2), true);',
  1565. '']));
  1566. end;
  1567. procedure TTestGenerics.TestGen_ClassInterface_COM_RTTI;
  1568. begin
  1569. StartProgram(true,[supTInterfacedObject]);
  1570. Add([
  1571. '{$mode delphi}',
  1572. 'type',
  1573. ' TBird = class',
  1574. ' function Fly<T: IInterface>: T;',
  1575. ' end;',
  1576. ' IAnt = interface',
  1577. ' procedure InterfaceProc;',
  1578. ' end;',
  1579. 'function TBird.Fly<T>: T;',
  1580. 'begin',
  1581. ' if TypeInfo(T)=nil then ;',
  1582. 'end;',
  1583. 'var Bird: TBird;',
  1584. ' Ant: IAnt;',
  1585. 'begin',
  1586. ' Ant := Bird.Fly<IAnt>;',
  1587. '']);
  1588. ConvertProgram;
  1589. CheckSource('TestGen_ClassInterface_COM_RTTI',
  1590. LinesToStr([ // statements
  1591. 'rtl.createClass(this, "TBird", pas.system.TObject, function () {',
  1592. ' this.Fly$G1 = function () {',
  1593. ' var Result = null;',
  1594. ' if ($mod.$rtti["IAnt"] === null) ;',
  1595. ' return Result;',
  1596. ' };',
  1597. '});',
  1598. 'rtl.createInterface(this, "IAnt", "{B9D0FF27-A446-3A1B-AA85-F167837AA297}", ["InterfaceProc"], pas.system.IUnknown);',
  1599. 'this.Bird = null;',
  1600. 'this.Ant = null;',
  1601. '']),
  1602. LinesToStr([ // $mod.$main
  1603. 'rtl.setIntfP($mod, "Ant", $mod.Bird.Fly$G1(), true);',
  1604. '']));
  1605. end;
  1606. procedure TTestGenerics.TestGen_ClassInterface_Helper;
  1607. begin
  1608. StartProgram(true,[supTInterfacedObject]);
  1609. Add([
  1610. '{$mode objfpc}',
  1611. '{$ModeSwitch typehelpers}',
  1612. 'type',
  1613. ' IAnt = interface',
  1614. ' procedure InterfaceProc;',
  1615. ' end;',
  1616. ' TBird = type helper for IAnt',
  1617. ' generic procedure Fly<T>(a: T);',
  1618. ' end;',
  1619. 'generic procedure TBird.Fly<T>(a: T);',
  1620. 'begin',
  1621. 'end;',
  1622. 'var ',
  1623. ' Ant: IAnt;',
  1624. 'begin',
  1625. ' Ant.specialize Fly<word>(3);',
  1626. '']);
  1627. ConvertProgram;
  1628. CheckSource('TestGen_ClassInterface_COM_RTTI',
  1629. LinesToStr([ // statements
  1630. 'rtl.createInterface(this, "IAnt", "{B9D0FF27-A446-3A1B-AA85-F167837AA297}", ["InterfaceProc"], pas.system.IUnknown);',
  1631. 'rtl.createHelper(this, "TBird", null, function () {',
  1632. ' this.Fly$G1 = function (a) {',
  1633. ' };',
  1634. '});',
  1635. 'this.Ant = null;',
  1636. '']),
  1637. LinesToStr([ // $mod.$main
  1638. '$mod.TBird.Fly$G1.call({',
  1639. ' p: $mod,',
  1640. ' get: function () {',
  1641. ' return this.p.Ant;',
  1642. ' },',
  1643. ' set: function (v) {',
  1644. ' rtl.setIntfP(this.p, "Ant", v);',
  1645. ' }',
  1646. '}, 3);',
  1647. '']));
  1648. end;
  1649. procedure TTestGenerics.TestGen_ClassInterface_DelayedInitSpec;
  1650. begin
  1651. WithTypeInfo:=true;
  1652. StartProgram(true,[supTObject,supTInterfacedObject]);
  1653. AddModuleWithIntfImplSrc('UnitA.pas',
  1654. LinesToStr([
  1655. '{$mode delphi}',
  1656. 'type',
  1657. ' TAnt<T> = interface',
  1658. ' procedure Run(x: T);',
  1659. ' end;',
  1660. '']),
  1661. LinesToStr([
  1662. '']));
  1663. Add([
  1664. '{$mode delphi}',
  1665. 'uses UnitA;',
  1666. 'type',
  1667. ' TArrWord = array of word;',
  1668. ' TMyIntf = TAnt<TArrWord>;',
  1669. ' TBird = class(TInterfacedObject,TMyIntf)',
  1670. ' procedure Run(a: TArrWord); external name ''Run'';',
  1671. ' end;',
  1672. 'var',
  1673. ' i: TMyIntf;',
  1674. 'begin',
  1675. ' i:=TBird.Create;',
  1676. ' i.Run([3,4]);',
  1677. 'end.']);
  1678. ConvertProgram;
  1679. CheckUnit('UnitA.pas',
  1680. LinesToStr([ // statements
  1681. 'rtl.module("UnitA", ["system"], function () {',
  1682. ' var $mod = this;',
  1683. ' $mod.$rtti.$Interface("TAnt<test1.TArrWord>");',
  1684. ' rtl.createInterface(',
  1685. ' this,',
  1686. ' "TAnt$G1",',
  1687. ' "{B145F21B-2696-32D5-87A5-F16C037A2D45}",',
  1688. ' ["Run"],',
  1689. ' pas.system.IUnknown,',
  1690. ' function () {',
  1691. ' this.$initSpec = function () {',
  1692. ' var $r = this.$rtti;',
  1693. ' $r.addMethod("Run", 0, [["x", pas.program.$rtti["TArrWord"]]]);',
  1694. ' };',
  1695. ' },',
  1696. ' "TAnt<test1.TArrWord>"',
  1697. ' );',
  1698. '});']));
  1699. CheckSource('TestGen_ClassInterface_DelayedInitSpec',
  1700. LinesToStr([ // statements
  1701. 'this.$rtti.$DynArray("TArrWord", {',
  1702. ' eltype: rtl.word',
  1703. '});',
  1704. 'rtl.createClass(this, "TBird", pas.system.TInterfacedObject, function () {',
  1705. ' rtl.addIntf(this, pas.UnitA.TAnt$G1);',
  1706. ' rtl.addIntf(this, pas.system.IUnknown);',
  1707. '});',
  1708. 'this.i = null;',
  1709. '$mod.$implcode = function () {',
  1710. ' pas.UnitA.TAnt$G1.$initSpec();',
  1711. '};',
  1712. '']),
  1713. LinesToStr([ // $mod.$main
  1714. 'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.TBird.$create("Create"), pas.UnitA.TAnt$G1), true);',
  1715. '$mod.i.Run([3, 4]);',
  1716. '']));
  1717. end;
  1718. procedure TTestGenerics.TestGen_InlineSpec_Constructor;
  1719. begin
  1720. StartProgram(false);
  1721. Add([
  1722. '{$mode objfpc}',
  1723. 'type',
  1724. ' TObject = class',
  1725. ' public',
  1726. ' constructor Create;',
  1727. ' end;',
  1728. ' generic TBird<T> = class',
  1729. ' end;',
  1730. 'constructor TObject.Create; begin end;',
  1731. 'var b: specialize TBird<word>;',
  1732. 'begin',
  1733. ' b:=specialize TBird<word>.Create;',
  1734. '']);
  1735. ConvertProgram;
  1736. CheckSource('TestGen_InlineSpec_Constructor',
  1737. LinesToStr([ // statements
  1738. 'rtl.createClass(this, "TObject", null, function () {',
  1739. ' this.$init = function () {',
  1740. ' };',
  1741. ' this.$final = function () {',
  1742. ' };',
  1743. ' this.Create = function () {',
  1744. ' return this;',
  1745. ' };',
  1746. '});',
  1747. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  1748. '}, "TBird<System.Word>");',
  1749. 'this.b = null;',
  1750. '']),
  1751. LinesToStr([ // $mod.$main
  1752. '$mod.b = $mod.TBird$G1.$create("Create");',
  1753. '']));
  1754. end;
  1755. procedure TTestGenerics.TestGen_CallUnitImplProc;
  1756. begin
  1757. AddModuleWithIntfImplSrc('UnitA.pas',
  1758. LinesToStr([
  1759. 'type',
  1760. ' generic TBird<T> = class',
  1761. ' procedure Fly;',
  1762. ' end;',
  1763. 'var b: specialize TBird<boolean>;',
  1764. '']),
  1765. LinesToStr([
  1766. 'procedure DoIt;',
  1767. 'var b: specialize TBird<word>;',
  1768. 'begin',
  1769. ' b:=specialize TBird<word>.Create;',
  1770. ' b.Fly;',
  1771. 'end;',
  1772. 'procedure TBird.Fly;',
  1773. 'begin',
  1774. ' DoIt;',
  1775. 'end;',
  1776. '']));
  1777. StartProgram(true,[supTObject]);
  1778. Add('uses UnitA;');
  1779. Add('begin');
  1780. ConvertProgram;
  1781. CheckUnit('UnitA.pas',
  1782. LinesToStr([ // statements
  1783. 'rtl.module("UnitA", ["system"], function () {',
  1784. ' var $mod = this;',
  1785. ' var $impl = $mod.$impl;',
  1786. ' rtl.createClass(this, "TBird$G1", pas.system.TObject, function () {',
  1787. ' this.Fly = function () {',
  1788. ' $impl.DoIt();',
  1789. ' };',
  1790. ' }, "TBird<System.Boolean>");',
  1791. ' this.b = null;',
  1792. ' rtl.createClass(this, "TBird$G2", pas.system.TObject, function () {',
  1793. ' this.Fly = function () {',
  1794. ' $impl.DoIt();',
  1795. ' };',
  1796. ' }, "TBird<System.Word>");',
  1797. ' $mod.$implcode = function () {',
  1798. ' $impl.DoIt = function () {',
  1799. ' var b = null;',
  1800. ' b = $mod.TBird$G2.$create("Create");',
  1801. ' b.Fly();',
  1802. ' };',
  1803. ' };',
  1804. '}, []);',
  1805. '']));
  1806. end;
  1807. procedure TTestGenerics.TestGen_IntAssignTemplVar;
  1808. begin
  1809. StartProgram(false);
  1810. Add([
  1811. 'type',
  1812. ' TObject = class end;',
  1813. ' generic TBird<T> = class',
  1814. ' m: T;',
  1815. ' procedure Fly;',
  1816. ' end;',
  1817. 'var b: specialize TBird<word>;',
  1818. 'procedure TBird.Fly;',
  1819. 'var i: nativeint;',
  1820. 'begin',
  1821. ' i:=m;',
  1822. 'end;',
  1823. 'begin',
  1824. '']);
  1825. ConvertProgram;
  1826. CheckSource('TestGen_IntAssignTemplVar',
  1827. LinesToStr([ // statements
  1828. 'rtl.createClass(this, "TObject", null, function () {',
  1829. ' this.$init = function () {',
  1830. ' };',
  1831. ' this.$final = function () {',
  1832. ' };',
  1833. '});',
  1834. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  1835. ' this.$init = function () {',
  1836. ' $mod.TObject.$init.call(this);',
  1837. ' this.m = 0;',
  1838. ' };',
  1839. ' this.Fly = function () {',
  1840. ' var i = 0;',
  1841. ' i = this.m;',
  1842. ' };',
  1843. '}, "TBird<System.Word>");',
  1844. 'this.b = null;',
  1845. '']),
  1846. LinesToStr([ // $mod.$main
  1847. '']));
  1848. end;
  1849. procedure TTestGenerics.TestGen_TypeCastDotField;
  1850. begin
  1851. StartProgram(false);
  1852. Add([
  1853. 'type',
  1854. ' TObject = class end;',
  1855. ' generic TBird<T> = class',
  1856. ' Field: T;',
  1857. ' procedure Fly;',
  1858. ' end;',
  1859. 'var',
  1860. ' o: TObject;',
  1861. ' b: specialize TBird<word>;',
  1862. 'procedure TBird.Fly;',
  1863. 'begin',
  1864. ' specialize TBird<word>(o).Field:=3;',
  1865. ' if 4=specialize TBird<word>(o).Field then ;',
  1866. 'end;',
  1867. 'begin',
  1868. ' specialize TBird<word>(o).Field:=5;',
  1869. ' if 6=specialize TBird<word>(o).Field then ;',
  1870. '']);
  1871. ConvertProgram;
  1872. CheckSource('TestGen_TypeCastDotField',
  1873. LinesToStr([ // statements
  1874. 'rtl.createClass(this, "TObject", null, function () {',
  1875. ' this.$init = function () {',
  1876. ' };',
  1877. ' this.$final = function () {',
  1878. ' };',
  1879. '});',
  1880. 'this.o = null;',
  1881. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  1882. ' this.$init = function () {',
  1883. ' $mod.TObject.$init.call(this);',
  1884. ' this.Field = 0;',
  1885. ' };',
  1886. ' this.Fly = function () {',
  1887. ' $mod.o.Field = 3;',
  1888. ' if (4 === $mod.o.Field) ;',
  1889. ' };',
  1890. '}, "TBird<System.Word>");',
  1891. 'this.b = null;',
  1892. '']),
  1893. LinesToStr([ // $mod.$main
  1894. '$mod.o.Field = 5;',
  1895. 'if (6 === $mod.o.Field) ;',
  1896. '']));
  1897. end;
  1898. procedure TTestGenerics.TestGen_Except;
  1899. begin
  1900. StartProgram(false);
  1901. Add([
  1902. 'type',
  1903. ' TObject = class end;',
  1904. ' generic TBird<T> = class',
  1905. ' Field: T;',
  1906. ' procedure Fly;',
  1907. ' end;',
  1908. ' Exception = class',
  1909. ' end;',
  1910. ' generic EBird<T> = class(Exception)',
  1911. ' Id: T;',
  1912. ' end;',
  1913. 'var',
  1914. ' b: specialize TBird<word>;',
  1915. 'procedure TBird.Fly;',
  1916. 'begin',
  1917. ' try',
  1918. ' except',
  1919. ' on E: Exception do Fly;',
  1920. ' on EBird: specialize EBird<word> do EBird.Id:=3;',
  1921. ' else',
  1922. ' Fly;',
  1923. ' end;',
  1924. 'end;',
  1925. 'begin',
  1926. '']);
  1927. ConvertProgram;
  1928. CheckSource('TestGen_Except',
  1929. LinesToStr([ // statements
  1930. 'rtl.createClass(this, "TObject", null, function () {',
  1931. ' this.$init = function () {',
  1932. ' };',
  1933. ' this.$final = function () {',
  1934. ' };',
  1935. '});',
  1936. 'rtl.createClass(this, "Exception", this.TObject, function () {',
  1937. '});',
  1938. 'rtl.createClass(this, "TBird$G1", this.TObject, function () {',
  1939. ' this.$init = function () {',
  1940. ' $mod.TObject.$init.call(this);',
  1941. ' this.Field = 0;',
  1942. ' };',
  1943. ' this.Fly = function () {',
  1944. ' try {} catch ($e) {',
  1945. ' if ($mod.Exception.isPrototypeOf($e)) {',
  1946. ' var E = $e;',
  1947. ' this.Fly();',
  1948. ' } else if ($mod.EBird$G1.isPrototypeOf($e)) {',
  1949. ' var EBird = $e;',
  1950. ' EBird.Id = 3;',
  1951. ' } else {',
  1952. ' this.Fly();',
  1953. ' }',
  1954. ' };',
  1955. ' };',
  1956. '}, "TBird<System.Word>");',
  1957. 'this.b = null;',
  1958. 'rtl.createClass(this, "EBird$G1", this.Exception, function () {',
  1959. ' this.$init = function () {',
  1960. ' $mod.Exception.$init.call(this);',
  1961. ' this.Id = 0;',
  1962. ' };',
  1963. '}, "EBird<System.Word>");',
  1964. '']),
  1965. LinesToStr([ // $mod.$main
  1966. '']));
  1967. end;
  1968. procedure TTestGenerics.TestGen_HelperForArray;
  1969. begin
  1970. StartProgram(false);
  1971. Add([
  1972. '{$ModeSwitch typehelpers}',
  1973. 'type',
  1974. ' generic TArr<T> = array[1..2] of T;',
  1975. ' TWordArrHelper = type helper for specialize TArr<word>',
  1976. ' procedure Fly(w: word);',
  1977. ' end;',
  1978. 'procedure TWordArrHelper.Fly(w: word);',
  1979. 'begin',
  1980. 'end;',
  1981. 'var',
  1982. ' a: specialize TArr<word>;',
  1983. 'begin',
  1984. ' a.Fly(3);',
  1985. '']);
  1986. ConvertProgram;
  1987. CheckSource('TestGen_HelperForArray',
  1988. LinesToStr([ // statements
  1989. 'rtl.createHelper(this, "TWordArrHelper", null, function () {',
  1990. ' this.Fly = function (w) {',
  1991. ' };',
  1992. '});',
  1993. 'this.a = rtl.arraySetLength(null, 0, 2);',
  1994. '']),
  1995. LinesToStr([ // $mod.$main
  1996. '$mod.TWordArrHelper.Fly.call({',
  1997. ' p: $mod,',
  1998. ' get: function () {',
  1999. ' return this.p.a;',
  2000. ' },',
  2001. ' set: function (v) {',
  2002. ' this.p.a = v;',
  2003. ' }',
  2004. '}, 3);',
  2005. '']));
  2006. end;
  2007. procedure TTestGenerics.TestGenProc_Function_ObjFPC;
  2008. begin
  2009. StartProgram(false);
  2010. Add([
  2011. 'generic function Run<T>(a: T): T;',
  2012. 'var i: T;',
  2013. 'begin',
  2014. ' a:=i;',
  2015. ' Result:=a;',
  2016. 'end;',
  2017. 'var w: word;',
  2018. 'begin',
  2019. ' w:=specialize Run<word>(3);',
  2020. '']);
  2021. ConvertProgram;
  2022. CheckSource('TestGenProc_Function_ObjFPC',
  2023. LinesToStr([ // statements
  2024. 'this.w = 0;',
  2025. 'this.Run$G1 = function (a) {',
  2026. ' var Result = 0;',
  2027. ' var i = 0;',
  2028. ' a = i;',
  2029. ' Result = a;',
  2030. ' return Result;',
  2031. '};',
  2032. '']),
  2033. LinesToStr([ // $mod.$main
  2034. '$mod.w = $mod.Run$G1(3);',
  2035. '']));
  2036. end;
  2037. procedure TTestGenerics.TestGenProc_Function_Delphi;
  2038. begin
  2039. StartProgram(false);
  2040. Add([
  2041. '{$mode delphi}',
  2042. 'function Run<T>(a: T): T;',
  2043. 'var i: T;',
  2044. 'begin',
  2045. ' a:=i;',
  2046. ' Result:=a;',
  2047. 'end;',
  2048. 'var w: word;',
  2049. 'begin',
  2050. ' w:=Run<word>(3);',
  2051. '']);
  2052. ConvertProgram;
  2053. CheckSource('TestGenProc_Function_Delphi',
  2054. LinesToStr([ // statements
  2055. 'this.w = 0;',
  2056. 'this.Run$G1 = function (a) {',
  2057. ' var Result = 0;',
  2058. ' var i = 0;',
  2059. ' a = i;',
  2060. ' Result = a;',
  2061. ' return Result;',
  2062. '};',
  2063. '']),
  2064. LinesToStr([ // $mod.$main
  2065. '$mod.w = $mod.Run$G1(3);',
  2066. '']));
  2067. end;
  2068. procedure TTestGenerics.TestGenProc_Overload;
  2069. begin
  2070. StartProgram(false);
  2071. Add([
  2072. 'generic procedure DoIt<T>(a: T; w: word); overload;',
  2073. 'begin',
  2074. 'end;',
  2075. 'generic procedure DoIt<T>(a: T; b: boolean); overload;',
  2076. 'begin',
  2077. 'end;',
  2078. 'begin',
  2079. ' specialize DoIt<word>(3,4);',
  2080. ' specialize DoIt<boolean>(false,5);',
  2081. ' specialize DoIt<word>(6,true);',
  2082. ' specialize DoIt<double>(7.3,true);',
  2083. '']);
  2084. ConvertProgram;
  2085. CheckSource('TestGenProc_Overload',
  2086. LinesToStr([ // statements
  2087. 'this.DoIt$G1 = function (a, w) {',
  2088. '};',
  2089. 'this.DoIt$G2 = function (a, w) {',
  2090. '};',
  2091. 'this.DoIt$1G1 = function (a, b) {',
  2092. '};',
  2093. 'this.DoIt$1G2 = function (a, b) {',
  2094. '};',
  2095. '']),
  2096. LinesToStr([ // $mod.$main
  2097. '$mod.DoIt$G1(3, 4);',
  2098. '$mod.DoIt$G2(false, 5);',
  2099. '$mod.DoIt$1G1(6, true);',
  2100. '$mod.DoIt$1G2(7.3, true);',
  2101. '']));
  2102. end;
  2103. procedure TTestGenerics.TestGenProc_Forward;
  2104. begin
  2105. StartProgram(false);
  2106. Add([
  2107. '{$mode delphi}',
  2108. 'procedure Run<S>(a: S; b: boolean); forward;',
  2109. 'procedure Run<S>(a: S; b: boolean);',
  2110. 'begin',
  2111. ' Run<word>(1,true);',
  2112. 'end;',
  2113. 'begin',
  2114. ' Run(1.3,true);',
  2115. '']);
  2116. ConvertProgram;
  2117. CheckSource('TestGenProc_infer_OverloadForward',
  2118. LinesToStr([ // statements
  2119. 'this.Run$G1 = function (a, b) {',
  2120. ' $mod.Run$G1(1, true);',
  2121. '};',
  2122. 'this.Run$G2 = function (a, b) {',
  2123. ' $mod.Run$G1(1, true);',
  2124. '};',
  2125. '']),
  2126. LinesToStr([ // $mod.$main
  2127. '$mod.Run$G2(1.3, true);',
  2128. '']));
  2129. end;
  2130. procedure TTestGenerics.TestGenProc_Infer_OverloadForward;
  2131. begin
  2132. StartProgram(false);
  2133. Add([
  2134. '{$mode delphi}',
  2135. 'procedure {#A}Run<S>(a: S; b: boolean); forward; overload;',
  2136. 'procedure {#B}Run<T>(a: T; w: word); forward; overload;',
  2137. 'procedure {#C}Run<U>(a: U; b: U); forward; overload;',
  2138. 'procedure {#A2}Run<S>(a: S; b: boolean); overload;',
  2139. 'begin',
  2140. ' {@A}Run(1,true);', // non generic take precedence
  2141. ' {@B}Run(2,word(3));', // non generic take precedence
  2142. ' {@C}Run(''foo'',''bar'');',
  2143. 'end;',
  2144. 'procedure {#B2}Run<T>(a: T; w: word); overload;',
  2145. 'begin',
  2146. 'end;',
  2147. 'procedure {#C2}Run<U>(a: U; b: U); overload;',
  2148. 'begin',
  2149. 'end;',
  2150. 'begin',
  2151. ' {@A}Run(1,true);', // non generic take precedence
  2152. ' {@B}Run(2,word(3));', // non generic take precedence
  2153. ' {@C}Run(''foo'',''bar'');',
  2154. '']);
  2155. ConvertProgram;
  2156. CheckSource('TestGenProc_infer_OverloadForward',
  2157. LinesToStr([ // statements
  2158. 'this.Run$G1 = function (a, b) {',
  2159. ' $mod.Run$G1(1, true);',
  2160. ' $mod.Run$1G1(2, 3);',
  2161. ' $mod.Run$2G1("foo", "bar");',
  2162. '};',
  2163. 'this.Run$1G1 = function (a, w) {',
  2164. '};',
  2165. 'this.Run$2G1 = function (a, b) {',
  2166. '};',
  2167. '']),
  2168. LinesToStr([ // $mod.$main
  2169. '$mod.Run$G1(1, true);',
  2170. '$mod.Run$1G1(2, 3);',
  2171. '$mod.Run$2G1("foo", "bar");',
  2172. '']));
  2173. end;
  2174. procedure TTestGenerics.TestGenProc_TypeInfo;
  2175. begin
  2176. WithTypeInfo:=true;
  2177. StartProgram(true,[supTypeInfo]);
  2178. Add([
  2179. '{$modeswitch implicitfunctionspecialization}',
  2180. 'generic procedure Run<S>(a: S);',
  2181. 'var',
  2182. ' p: TTypeInfo;',
  2183. 'begin',
  2184. ' p:=TypeInfo(S);',
  2185. ' p:=TypeInfo(a);',
  2186. 'end;',
  2187. 'begin',
  2188. ' Run(word(3));',
  2189. ' Run(''foo'');',
  2190. '']);
  2191. ConvertProgram;
  2192. CheckSource('TestGenProc_TypeInfo',
  2193. LinesToStr([ // statements
  2194. 'this.Run$G1 = function (a) {',
  2195. ' var p = null;',
  2196. ' p = rtl.word;',
  2197. ' p = rtl.word;',
  2198. '};',
  2199. 'this.Run$G2 = function (a) {',
  2200. ' var p = null;',
  2201. ' p = rtl.string;',
  2202. ' p = rtl.string;',
  2203. '};',
  2204. '']),
  2205. LinesToStr([ // $mod.$main
  2206. '$mod.Run$G1(3);',
  2207. '$mod.Run$G2("foo");',
  2208. '']));
  2209. end;
  2210. procedure TTestGenerics.TestGenProc_Infer_Widen;
  2211. begin
  2212. StartProgram(false);
  2213. Add([
  2214. '{$mode delphi}',
  2215. 'procedure Run<S>(a: S; b: S);',
  2216. 'begin',
  2217. 'end;',
  2218. 'begin',
  2219. ' Run(word(1),longint(2));',
  2220. ' Run(byte(2),smallint(2));',
  2221. ' Run(longword(3),longint(2));',
  2222. ' Run(nativeint(4),longint(2));',
  2223. ' Run(nativeint(5),nativeuint(2));',
  2224. ' Run(''a'',''foo'');',
  2225. ' Run(''bar'',''c'');',
  2226. '']);
  2227. ConvertProgram;
  2228. CheckSource('TestGenProc_Infer_Widen',
  2229. LinesToStr([ // statements
  2230. 'this.Run$G1 = function (a, b) {',
  2231. '};',
  2232. 'this.Run$G2 = function (a, b) {',
  2233. '};',
  2234. 'this.Run$G3 = function (a, b) {',
  2235. '};',
  2236. '']),
  2237. LinesToStr([ // $mod.$main
  2238. '$mod.Run$G1(1, 2);',
  2239. '$mod.Run$G1(2, 2);',
  2240. '$mod.Run$G2(3, 2);',
  2241. '$mod.Run$G2(4, 2);',
  2242. '$mod.Run$G2(5, 2);',
  2243. '$mod.Run$G3("a", "foo");',
  2244. '$mod.Run$G3("bar", "c");',
  2245. '']));
  2246. end;
  2247. procedure TTestGenerics.TestGenProc_Infer_PassAsArg;
  2248. begin
  2249. StartProgram(false);
  2250. Add([
  2251. '{$mode delphi}',
  2252. 'function Run<T>(a: T): T;',
  2253. 'var b: T;',
  2254. 'begin',
  2255. ' Run(Run<word>(3));',
  2256. ' Run(Run(word(4)));',
  2257. 'end;',
  2258. 'begin',
  2259. ' Run(Run<word>(5));',
  2260. ' Run(Run(word(6)));',
  2261. '']);
  2262. ConvertProgram;
  2263. CheckSource('TestGenProc_Infer_PassAsArg',
  2264. LinesToStr([ // statements
  2265. 'this.Run$G1 = function (a) {',
  2266. ' var Result = 0;',
  2267. ' var b = 0;',
  2268. ' $mod.Run$G1($mod.Run$G1(3));',
  2269. ' $mod.Run$G1($mod.Run$G1(4));',
  2270. ' return Result;',
  2271. '};',
  2272. '']),
  2273. LinesToStr([ // $mod.$main
  2274. '$mod.Run$G1($mod.Run$G1(5));',
  2275. '$mod.Run$G1($mod.Run$G1(6));',
  2276. '']));
  2277. end;
  2278. procedure TTestGenerics.TestGenProc_AnonymousProc;
  2279. begin
  2280. StartProgram(false);
  2281. Add([
  2282. '{$mode delphi}',
  2283. 'type',
  2284. ' TProc = reference to procedure;',
  2285. ' TFunc = reference to function(Value: JSValue): JSValue;',
  2286. 'function Run<T>(a: T; p: TProc): T;',
  2287. 'var b: T;',
  2288. ' f: TFunc;',
  2289. 'begin',
  2290. ' Result:=Run(a,procedure()begin end);',
  2291. ' f:=function(b: JSValue): JSValue begin end;',
  2292. ' f:=function(b: JSValue): JSValue',
  2293. ' function Sub(c: JSValue): JSValue;',
  2294. ' begin',
  2295. ' Result:=c;',
  2296. ' end;',
  2297. ' begin',
  2298. ' Result:=Sub(b);',
  2299. ' end;',
  2300. 'end;',
  2301. 'begin',
  2302. ' Run<word>(3,procedure() begin end);',
  2303. '']);
  2304. ConvertProgram;
  2305. CheckSource('TestGenProc_AnonymousProc',
  2306. LinesToStr([ // statements
  2307. 'this.Run$G1 = function (a, p) {',
  2308. ' var Result = 0;',
  2309. ' var b = 0;',
  2310. ' var f = null;',
  2311. ' Result = $mod.Run$G1(a, function () {',
  2312. ' });',
  2313. ' f = function (b) {',
  2314. ' var Result = undefined;',
  2315. ' return Result;',
  2316. ' };',
  2317. ' f = function (b) {',
  2318. ' var Result = undefined;',
  2319. ' function Sub(c) {',
  2320. ' var Result = undefined;',
  2321. ' Result = c;',
  2322. ' return Result;',
  2323. ' };',
  2324. ' Result = Sub(b);',
  2325. ' return Result;',
  2326. ' };',
  2327. ' return Result;',
  2328. '};',
  2329. '']),
  2330. LinesToStr([ // $mod.$main
  2331. '$mod.Run$G1(3, function () {',
  2332. '});',
  2333. '']));
  2334. end;
  2335. procedure TTestGenerics.TestGenMethod_ImplicitSpec_ObjFPC;
  2336. begin
  2337. StartProgram(false);
  2338. Add([
  2339. '{$mode objfpc}',
  2340. '{$ModeSwitch implicitfunctionspecialization}',
  2341. 'type',
  2342. ' TObject = class',
  2343. ' generic procedure {#A}Run<S>(a: S; b: boolean); overload;',
  2344. ' generic procedure {#B}Run<T>(a: T; w: word); overload;',
  2345. ' generic procedure {#C}Run<U>(a: U; b: U); overload;',
  2346. ' end; ',
  2347. 'generic procedure {#A2}TObject.Run<S>(a: S; b: boolean); overload;',
  2348. 'begin',
  2349. ' {@A}Run(1,true);', // non generic take precedence
  2350. ' {@B}Run(2,word(3));', // non generic take precedence
  2351. ' {@C}Run(''foo'',''bar'');',
  2352. 'end;',
  2353. 'generic procedure {#B2}TObject.Run<T>(a: T; w: word); overload;',
  2354. 'begin',
  2355. 'end;',
  2356. 'generic procedure {#C2}TObject.Run<U>(a: U; b: U); overload;',
  2357. 'begin',
  2358. 'end;',
  2359. 'var o: TObject;',
  2360. 'begin',
  2361. ' o.{@A}Run(1,true);', // non generic take precedence
  2362. ' o.{@B}Run(2,word(3));', // non generic take precedence
  2363. ' o.{@C}Run(''foo'',''bar'');',
  2364. '']);
  2365. ConvertProgram;
  2366. CheckSource('TestGenMethod_ImplicitSpec_ObjFPC',
  2367. LinesToStr([ // statements
  2368. 'rtl.createClass(this, "TObject", null, function () {',
  2369. ' this.$init = function () {',
  2370. ' };',
  2371. ' this.$final = function () {',
  2372. ' };',
  2373. ' this.Run$G1 = function (a, b) {',
  2374. ' this.Run$G1(1, true);',
  2375. ' this.Run$1G1(2, 3);',
  2376. ' this.Run$2G1("foo", "bar");',
  2377. ' };',
  2378. ' this.Run$1G1 = function (a, w) {',
  2379. ' };',
  2380. ' this.Run$2G1 = function (a, b) {',
  2381. ' };',
  2382. '});',
  2383. 'this.o = null;',
  2384. '']),
  2385. LinesToStr([ // $mod.$main
  2386. '$mod.o.Run$G1(1, true);',
  2387. '$mod.o.Run$1G1(2, 3);',
  2388. '$mod.o.Run$2G1("foo", "bar");',
  2389. '']));
  2390. end;
  2391. procedure TTestGenerics.TestGenMethod_Delphi;
  2392. begin
  2393. StartProgram(false);
  2394. Add([
  2395. '{$mode delphi}',
  2396. 'type',
  2397. ' TObject = class',
  2398. ' procedure Run<S>;',
  2399. ' end; ',
  2400. 'procedure TObject.Run<S>;',
  2401. 'begin',
  2402. 'end;',
  2403. 'var o: TObject;',
  2404. 'begin',
  2405. ' o.Run<word>;',
  2406. ' o.Run<word>();',
  2407. ' with o do begin',
  2408. ' Run<word>;',
  2409. ' Run<word>();',
  2410. ' end;',
  2411. '']);
  2412. ConvertProgram;
  2413. CheckSource('TestGenMethod_Delphi',
  2414. LinesToStr([ // statements
  2415. 'rtl.createClass(this, "TObject", null, function () {',
  2416. ' this.$init = function () {',
  2417. ' };',
  2418. ' this.$final = function () {',
  2419. ' };',
  2420. ' this.Run$G1 = function () {',
  2421. ' };',
  2422. '});',
  2423. 'this.o = null;',
  2424. '']),
  2425. LinesToStr([ // $mod.$main
  2426. '$mod.o.Run$G1();',
  2427. '$mod.o.Run$G1();',
  2428. 'var $with = $mod.o;',
  2429. '$with.Run$G1();',
  2430. '$with.Run$G1();',
  2431. '']));
  2432. end;
  2433. procedure TTestGenerics.TestGen_Array_OtherUnit;
  2434. begin
  2435. WithTypeInfo:=true;
  2436. StartProgram(true,[supTObject]);
  2437. AddModuleWithIntfImplSrc('UnitA.pas',
  2438. LinesToStr([
  2439. 'type',
  2440. ' generic TDyn<T> = array of T;',
  2441. ' generic TStatic<T> = array[1..2] of T;',
  2442. '']),
  2443. '');
  2444. AddModuleWithIntfImplSrc('UnitB.pas',
  2445. LinesToStr([
  2446. 'uses UnitA;',
  2447. 'type',
  2448. ' TAnt = class end;',
  2449. ' TAntArray = specialize TDyn<TAnt>;',
  2450. 'procedure Run;',
  2451. '']),
  2452. LinesToStr([
  2453. 'procedure Run;',
  2454. 'begin',
  2455. ' if typeinfo(TAntArray)=nil then ;',
  2456. 'end;',
  2457. '']));
  2458. Add([
  2459. 'uses UnitB;',
  2460. 'begin',
  2461. ' Run;',
  2462. '']);
  2463. ConvertProgram;
  2464. CheckUnit('UnitA.pas',
  2465. LinesToStr([ // statements
  2466. 'rtl.module("UnitA", ["system"], function () {',
  2467. ' var $mod = this;',
  2468. ' this.$rtti.$DynArray("TDyn<UnitB.TAnt>", {});',
  2469. '});']));
  2470. CheckUnit('UnitB.pas',
  2471. LinesToStr([ // statements
  2472. 'rtl.module("UnitB", ["system", "UnitA"], function () {',
  2473. ' var $mod = this;',
  2474. ' rtl.createClass(this, "TAnt", pas.system.TObject, function () {',
  2475. ' });',
  2476. ' this.Run = function () {',
  2477. ' if (pas.UnitA.$rtti["TDyn<UnitB.TAnt>"] === null) ;',
  2478. ' };',
  2479. '});']));
  2480. CheckSource('TestGen_Array_OtherUnit',
  2481. LinesToStr([ // statements
  2482. '$mod.$implcode = function () {',
  2483. ' pas.UnitA.$rtti["TDyn<UnitB.TAnt>"].eltype = pas.UnitB.$rtti["TAnt"];',
  2484. '};',
  2485. '']),
  2486. LinesToStr([ // $mod.$main
  2487. ' pas.UnitB.Run();',
  2488. '']));
  2489. end;
  2490. procedure TTestGenerics.TestGen_ArrayOfUnitImplRec;
  2491. begin
  2492. WithTypeInfo:=true;
  2493. StartProgram(true,[supTObject]);
  2494. AddModuleWithIntfImplSrc('UnitA.pas',
  2495. LinesToStr([
  2496. 'type',
  2497. ' generic TDyn<T> = array of T;',
  2498. ' generic TStatic<T> = array[1..2] of T;',
  2499. '']),
  2500. LinesToStr([
  2501. 'type',
  2502. ' TBird = record',
  2503. ' b: word;',
  2504. ' end;',
  2505. ' TAnt = class end;',
  2506. ' TAntArray = specialize TDyn<TAnt>;',
  2507. 'var',
  2508. ' d: specialize TDyn<TBird>;',
  2509. ' s: specialize TStatic<TBird>;',
  2510. ' p: pointer;',
  2511. 'begin',
  2512. ' d[0].b:=s[1].b;',
  2513. ' s:=s;',
  2514. ' p:=typeinfo(TAntArray);',
  2515. '']));
  2516. Add([
  2517. 'uses UnitA;',
  2518. 'begin',
  2519. '']);
  2520. ConvertProgram;
  2521. CheckUnit('UnitA.pas',
  2522. LinesToStr([ // statements
  2523. 'rtl.module("UnitA", ["system"], function () {',
  2524. ' var $mod = this;',
  2525. ' var $impl = $mod.$impl;',
  2526. ' this.$rtti.$DynArray("TDyn<UnitA.TAnt>", {});',
  2527. ' this.$rtti.$DynArray("TDyn<UnitA.TBird>", {});',
  2528. ' this.TStatic$G1$clone = function (a) {',
  2529. ' var r = [];',
  2530. ' for (var i = 0; i < 2; i++) r.push($impl.TBird.$clone(a[i]));',
  2531. ' return r;',
  2532. ' };',
  2533. ' this.$rtti.$StaticArray("TStatic<UnitA.TBird>", {',
  2534. ' dims: [2]',
  2535. ' });',
  2536. ' $mod.$implcode = function () {',
  2537. ' rtl.recNewT($impl, "TBird", function () {',
  2538. ' this.b = 0;',
  2539. ' this.$eq = function (b) {',
  2540. ' return this.b === b.b;',
  2541. ' };',
  2542. ' this.$assign = function (s) {',
  2543. ' this.b = s.b;',
  2544. ' return this;',
  2545. ' };',
  2546. ' var $r = $mod.$rtti.$Record("TBird", {});',
  2547. ' $r.addField("b", rtl.word);',
  2548. ' });',
  2549. ' rtl.createClass($impl, "TAnt", pas.system.TObject, function () {',
  2550. ' });',
  2551. ' $impl.d = [];',
  2552. ' $impl.s = rtl.arraySetLength(null, $impl.TBird, 2);',
  2553. ' $impl.p = null;',
  2554. ' };',
  2555. ' $mod.$init = function () {',
  2556. ' $impl.d[0].b = $impl.s[0].b;',
  2557. ' $impl.s = $mod.TStatic$G1$clone($impl.s);',
  2558. ' $impl.p = $mod.$rtti["TDyn<UnitA.TAnt>"];',
  2559. ' };',
  2560. '}, []);']));
  2561. CheckSource('TestGen_ArrayOfUnitImplRec',
  2562. LinesToStr([ // statements
  2563. '$mod.$implcode = function () {',
  2564. ' pas.UnitA.$rtti["TDyn<UnitA.TAnt>"].eltype = pas.UnitA.$rtti["TAnt"];',
  2565. ' pas.UnitA.$rtti["TDyn<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
  2566. ' pas.UnitA.$rtti["TStatic<UnitA.TBird>"].eltype = pas.UnitA.$rtti["TBird"];',
  2567. '};',
  2568. '']),
  2569. LinesToStr([ // $mod.$main
  2570. '']));
  2571. end;
  2572. procedure TTestGenerics.TestGen_Array_TypecastJSValueResultToArg;
  2573. begin
  2574. StartProgram(false);
  2575. Add([
  2576. '{$mode delphi}',
  2577. 'type',
  2578. ' TArray<T> = array of T;',
  2579. ' TFunc = function: JSValue of object;',
  2580. ' TObject = class',
  2581. ' f: TFunc;',
  2582. ' function Run: jsvalue; virtual; abstract;',
  2583. ' end;',
  2584. 'procedure Sit(Arr: TArray<TObject>);',
  2585. 'begin',
  2586. 'end;',
  2587. 'procedure Fly(o: TObject);',
  2588. 'begin',
  2589. ' Sit(TArray<TObject>(o.f()));',
  2590. ' Sit(TArray<TObject>(o.Run));',
  2591. ' Sit(TArray<TObject>(o.Run()));',
  2592. 'end;',
  2593. 'begin']);
  2594. ConvertProgram;
  2595. CheckSource('TestGen_Array_TypecastJSValueResultToArg',
  2596. LinesToStr([ // statements
  2597. 'rtl.createClass(this, "TObject", null, function () {',
  2598. ' this.$init = function () {',
  2599. ' this.f = null;',
  2600. ' };',
  2601. ' this.$final = function () {',
  2602. ' this.f = undefined;',
  2603. ' };',
  2604. '});',
  2605. 'this.Sit = function (Arr) {',
  2606. '};',
  2607. 'this.Fly = function (o) {',
  2608. ' $mod.Sit(o.f());',
  2609. ' $mod.Sit(o.Run());',
  2610. ' $mod.Sit(o.Run());',
  2611. '};',
  2612. '']),
  2613. LinesToStr([ // $mod.$main
  2614. '']));
  2615. end;
  2616. procedure TTestGenerics.TestGen_ProcType_ProcLocal;
  2617. begin
  2618. StartProgram(false);
  2619. Add([
  2620. 'procedure Fly(w: word);',
  2621. 'begin',
  2622. 'end;',
  2623. 'procedure Run(w: word);',
  2624. 'type generic TProc<T> = procedure(a: T);',
  2625. 'var p: specialize TProc<word>;',
  2626. 'begin',
  2627. ' p:=@Fly;',
  2628. ' p(w);',
  2629. 'end;',
  2630. 'begin',
  2631. 'end.']);
  2632. ConvertProgram;
  2633. CheckSource('TestGen_ProcType_ProcLocal',
  2634. LinesToStr([ // statements
  2635. 'this.Fly = function (w) {',
  2636. '};',
  2637. 'this.Run = function (w) {',
  2638. ' var p = null;',
  2639. ' p = $mod.Fly;',
  2640. ' p(w);',
  2641. '};',
  2642. '']),
  2643. LinesToStr([ // $mod.$main
  2644. '']));
  2645. end;
  2646. procedure TTestGenerics.TestGen_ProcType_Local_RTTI_Fail;
  2647. begin
  2648. WithTypeInfo:=true;
  2649. StartProgram(false);
  2650. Add([
  2651. 'procedure Fly(w: word);',
  2652. 'begin',
  2653. 'end;',
  2654. 'procedure Run(w: word);',
  2655. 'type generic TProc<T> = procedure(a: T);',
  2656. 'var',
  2657. ' p: specialize TProc<word>;',
  2658. ' t: Pointer;',
  2659. 'begin',
  2660. ' p:=@Fly;',
  2661. ' p(w);',
  2662. ' t:=typeinfo(p);',
  2663. 'end;',
  2664. 'begin',
  2665. 'end.']);
  2666. SetExpectedPasResolverError(sSymbolCannotBePublished,nSymbolCannotBePublished);
  2667. ConvertProgram;
  2668. end;
  2669. procedure TTestGenerics.TestGen_ProcType_ParamUnitImpl;
  2670. begin
  2671. WithTypeInfo:=true;
  2672. StartProgram(true,[supTObject]);
  2673. AddModuleWithIntfImplSrc('UnitA.pas',
  2674. LinesToStr([
  2675. 'type',
  2676. ' generic TAnt<T> = function(const a: T): T;',
  2677. '']),
  2678. LinesToStr([
  2679. 'type',
  2680. ' TBird = record',
  2681. ' b: word;',
  2682. ' end;',
  2683. 'var',
  2684. ' f: specialize TAnt<TBird>;',
  2685. ' b: TBird;',
  2686. ' p: pointer;',
  2687. 'begin',
  2688. ' b:=f(b);',
  2689. ' p:=typeinfo(f);',
  2690. '']));
  2691. Add([
  2692. 'uses UnitA;',
  2693. 'begin',
  2694. 'end.']);
  2695. ConvertProgram;
  2696. CheckUnit('UnitA.pas',
  2697. LinesToStr([ // statements
  2698. 'rtl.module("UnitA", ["system"], function () {',
  2699. ' var $mod = this;',
  2700. ' var $impl = $mod.$impl;',
  2701. ' this.$rtti.$ProcVar("TAnt<UnitA.TBird>", {',
  2702. ' init: function () {',
  2703. ' this.procsig = rtl.newTIProcSig([["a", $mod.$rtti["TBird"], 2]], $mod.$rtti["TBird"]);',
  2704. ' }',
  2705. ' });',
  2706. ' $mod.$implcode = function () {',
  2707. ' rtl.recNewT($impl, "TBird", function () {',
  2708. ' this.b = 0;',
  2709. ' this.$eq = function (b) {',
  2710. ' return this.b === b.b;',
  2711. ' };',
  2712. ' this.$assign = function (s) {',
  2713. ' this.b = s.b;',
  2714. ' return this;',
  2715. ' };',
  2716. ' var $r = $mod.$rtti.$Record("TBird", {});',
  2717. ' $r.addField("b", rtl.word);',
  2718. ' });',
  2719. ' $impl.f = null;',
  2720. ' $impl.b = $impl.TBird.$new();',
  2721. ' $impl.p = null;',
  2722. ' };',
  2723. ' $mod.$init = function () {',
  2724. ' $impl.b.$assign($impl.f($impl.b));',
  2725. ' $impl.p = $mod.$rtti["TAnt<UnitA.TBird>"];',
  2726. ' };',
  2727. '}, []);']));
  2728. CheckSource('TestGen_Class_ClassVarRecord_UnitImpl',
  2729. LinesToStr([ // statements
  2730. '$mod.$implcode = function () {',
  2731. ' pas.UnitA.$rtti["TAnt<UnitA.TBird>"].init();',
  2732. '};',
  2733. '']),
  2734. LinesToStr([ // $mod.$main
  2735. '']));
  2736. end;
  2737. Initialization
  2738. RegisterTests([TTestGenerics]);
  2739. end.