pgenutil.pas 75 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817
  1. {
  2. Copyright (c) 2011
  3. Contains different functions that are used in the context of
  4. parsing generics.
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pgenutil;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. { common }
  23. cclasses,
  24. { global }
  25. globtype,
  26. { parser }
  27. pgentype,
  28. { symtable }
  29. symtype,symdef,symbase;
  30. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string;parsedpos:tfileposinfo);inline;
  31. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string);inline;
  32. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;inline;
  33. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;inline;
  34. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
  35. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef;
  36. function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean;
  37. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  38. function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  39. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
  40. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  41. function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring;
  42. procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
  43. procedure add_generic_dummysym(sym:tsym);
  44. function resolve_generic_dummysym(const name:tidstring):tsym;
  45. function could_be_generic(const name:tidstring):boolean;inline;
  46. procedure generate_specialization_procs;
  47. procedure maybe_add_pending_specialization(def:tdef);
  48. procedure specialization_init(genericdef:tdef;var state:tspecializationstate);
  49. procedure specialization_done(var state:tspecializationstate);
  50. implementation
  51. uses
  52. { common }
  53. cutils,fpccrc,
  54. { global }
  55. globals,tokens,verbose,finput,
  56. { symtable }
  57. symconst,symsym,symtable,defcmp,procinfo,
  58. { modules }
  59. fmodule,
  60. node,nobj,
  61. { parser }
  62. scanner,
  63. pbase,pexpr,pdecsub,ptype,psub,pparautl;
  64. procedure maybe_add_waiting_unit(tt:tdef);
  65. var
  66. hmodule : tmodule;
  67. begin
  68. if not assigned(tt) or
  69. not (df_generic in tt.defoptions) then
  70. exit;
  71. hmodule:=find_module_from_symtable(tt.owner);
  72. if not assigned(hmodule) then
  73. internalerror(2012092401);
  74. if hmodule=current_module then
  75. exit;
  76. if hmodule.state<>ms_compiled then
  77. begin
  78. {$ifdef DEBUG_UNITWAITING}
  79. Writeln('Unit ', current_module.modulename^,
  80. ' waiting for ', hmodule.modulename^);
  81. {$endif DEBUG_UNITWAITING}
  82. if current_module.waitingforunit.indexof(hmodule)<0 then
  83. current_module.waitingforunit.add(hmodule);
  84. if hmodule.waitingunits.indexof(current_module)<0 then
  85. hmodule.waitingunits.add(current_module);
  86. end;
  87. end;
  88. function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean;
  89. var
  90. i,j,
  91. intfcount : longint;
  92. formaldef,
  93. paradef : tstoreddef;
  94. objdef,
  95. paraobjdef,
  96. formalobjdef : tobjectdef;
  97. intffound : boolean;
  98. filepos : tfileposinfo;
  99. begin
  100. { check whether the given specialization parameters fit to the eventual
  101. constraints of the generic }
  102. if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then
  103. internalerror(2012101001);
  104. if genericdef.genericparas.count<>paradeflist.count then
  105. internalerror(2012101002);
  106. if paradeflist.count<>poslist.count then
  107. internalerror(2012120801);
  108. result:=true;
  109. for i:=0 to genericdef.genericparas.count-1 do
  110. begin
  111. filepos:=pfileposinfo(poslist[i])^;
  112. formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef);
  113. if formaldef.typ=undefineddef then
  114. { the parameter is of unspecified type, so no need to check }
  115. continue;
  116. if not (df_genconstraint in formaldef.defoptions) or
  117. not assigned(formaldef.genconstraintdata) then
  118. internalerror(2013021602);
  119. paradef:=tstoreddef(paradeflist[i]);
  120. { undefineddef is compatible with anything }
  121. if formaldef.typ=undefineddef then
  122. continue;
  123. if paradef.typ<>formaldef.typ then
  124. begin
  125. case formaldef.typ of
  126. recorddef:
  127. { delphi has own fantasy about record constraint
  128. (almost non-nullable/non-nilable value type) }
  129. if m_delphi in current_settings.modeswitches then
  130. case paradef.typ of
  131. floatdef,enumdef,orddef:
  132. continue;
  133. objectdef:
  134. if tobjectdef(paradef).objecttype=odt_object then
  135. continue
  136. else
  137. MessagePos(filepos,type_e_record_type_expected);
  138. else
  139. MessagePos(filepos,type_e_record_type_expected);
  140. end
  141. else
  142. MessagePos(filepos,type_e_record_type_expected);
  143. objectdef:
  144. case tobjectdef(formaldef).objecttype of
  145. odt_class,
  146. odt_javaclass:
  147. MessagePos1(filepos,type_e_class_type_expected,paradef.typename);
  148. odt_interfacecom,
  149. odt_interfacecorba,
  150. odt_dispinterface,
  151. odt_interfacejava:
  152. MessagePos1(filepos,type_e_interface_type_expected,paradef.typename);
  153. else
  154. internalerror(2012101003);
  155. end;
  156. errordef:
  157. { ignore }
  158. ;
  159. else
  160. internalerror(2012101004);
  161. end;
  162. result:=false;
  163. end
  164. else
  165. begin
  166. { the paradef types are the same, so do special checks for the
  167. cases in which they are needed }
  168. if formaldef.typ=objectdef then
  169. begin
  170. paraobjdef:=tobjectdef(paradef);
  171. formalobjdef:=tobjectdef(formaldef);
  172. if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then
  173. internalerror(2012101102);
  174. if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then
  175. begin
  176. { this is either a concerete interface or class type (the
  177. latter without specific implemented interfaces) }
  178. case paraobjdef.objecttype of
  179. odt_interfacecom,
  180. odt_interfacecorba,
  181. odt_interfacejava,
  182. odt_dispinterface:
  183. begin
  184. if (oo_is_forward in paraobjdef.objectoptions) and
  185. (paraobjdef.objecttype=formalobjdef.objecttype) and
  186. (df_genconstraint in formalobjdef.defoptions) and
  187. (
  188. (formalobjdef.objecttype=odt_interfacecom) and
  189. (formalobjdef.childof=interface_iunknown)
  190. )
  191. or
  192. (
  193. (formalobjdef.objecttype=odt_interfacecorba) and
  194. (formalobjdef.childof=nil)
  195. ) then
  196. continue;
  197. if not def_is_related(paraobjdef,formalobjdef.childof) then
  198. begin
  199. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  200. result:=false;
  201. end;
  202. end;
  203. odt_class,
  204. odt_javaclass:
  205. begin
  206. objdef:=paraobjdef;
  207. intffound:=false;
  208. while assigned(objdef) do
  209. begin
  210. for j:=0 to objdef.implementedinterfaces.count-1 do
  211. if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then
  212. begin
  213. intffound:=true;
  214. break;
  215. end;
  216. if intffound then
  217. break;
  218. objdef:=objdef.childof;
  219. end;
  220. result:=intffound;
  221. if not result then
  222. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename);
  223. end;
  224. else
  225. begin
  226. MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename);
  227. result:=false;
  228. end;
  229. end;
  230. end
  231. else
  232. begin
  233. { this is either a "class" or a concrete instance with
  234. or without implemented interfaces }
  235. if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then
  236. begin
  237. MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename);
  238. result:=false;
  239. continue;
  240. end;
  241. { for forward declared classes we allow pure TObject/class declarations }
  242. if (oo_is_forward in paraobjdef.objectoptions) and
  243. (df_genconstraint in formaldef.defoptions) then
  244. begin
  245. if (formalobjdef.childof=class_tobject) and
  246. not formalobjdef.implements_any_interfaces then
  247. continue;
  248. end;
  249. if assigned(formalobjdef.childof) and
  250. not def_is_related(paradef,formalobjdef.childof) then
  251. begin
  252. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  253. result:=false;
  254. end;
  255. intfcount:=0;
  256. for j:=0 to formalobjdef.implementedinterfaces.count-1 do
  257. begin
  258. objdef:=paraobjdef;
  259. while assigned(objdef) do
  260. begin
  261. intffound:=assigned(
  262. find_implemented_interface(objdef,
  263. timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef
  264. )
  265. );
  266. if intffound then
  267. break;
  268. objdef:=objdef.childof;
  269. end;
  270. if intffound then
  271. inc(intfcount)
  272. else
  273. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename);
  274. end;
  275. if intfcount<>formalobjdef.implementedinterfaces.count then
  276. result:=false;
  277. end;
  278. end;
  279. end;
  280. end;
  281. end;
  282. function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
  283. var
  284. old_block_type : tblock_type;
  285. first : boolean;
  286. typeparam : tnode;
  287. parampos : pfileposinfo;
  288. tmpparampos : tfileposinfo;
  289. namepart : string;
  290. prettynamepart : ansistring;
  291. module : tmodule;
  292. begin
  293. result:=true;
  294. if genericdeflist=nil then
  295. internalerror(2012061401);
  296. { set the block type to type, so that the parsed type are returned as
  297. ttypenode (e.g. classes are in non type-compatible blocks returned as
  298. tloadvmtaddrnode) }
  299. old_block_type:=block_type;
  300. { if parsedtype is set, then the first type identifer was already parsed
  301. (happens in inline specializations) and thus we only need to parse
  302. the remaining types and do as if the first one was already given }
  303. first:=not assigned(parsedtype);
  304. if assigned(parsedtype) then
  305. begin
  306. genericdeflist.Add(parsedtype);
  307. module:=find_module_from_symtable(parsedtype.owner);
  308. if not assigned(module) then
  309. internalerror(2016112801);
  310. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+parsedtype.unique_id_str;
  311. specializename:='$'+namepart;
  312. prettyname:=parsedtype.fullownerhierarchyname(true)+parsedtype.typesym.prettyname;
  313. if assigned(poslist) then
  314. begin
  315. New(parampos);
  316. parampos^:=parsedpos;
  317. poslist.add(parampos);
  318. end;
  319. end
  320. else
  321. begin
  322. specializename:='$';
  323. prettyname:='';
  324. end;
  325. while not (token in [_GT,_RSHARPBRACKET]) do
  326. begin
  327. { "first" is set to false at the end of the loop! }
  328. if not first then
  329. consume(_COMMA);
  330. block_type:=bt_type;
  331. tmpparampos:=current_filepos;
  332. typeparam:=factor(false,[ef_type_only]);
  333. if typeparam.nodetype=typen then
  334. begin
  335. if tstoreddef(typeparam.resultdef).is_generic and
  336. (
  337. not parse_generic or
  338. not defs_belong_to_same_generic(typeparam.resultdef,current_genericdef)
  339. ) then
  340. Message(parser_e_no_generics_as_params);
  341. if assigned(poslist) then
  342. begin
  343. New(parampos);
  344. parampos^:=tmpparampos;
  345. poslist.add(parampos);
  346. end;
  347. if typeparam.resultdef.typ<>errordef then
  348. begin
  349. if not assigned(typeparam.resultdef.typesym) then
  350. message(type_e_generics_cannot_reference_itself)
  351. else if (typeparam.resultdef.typ<>errordef) then
  352. begin
  353. genericdeflist.Add(typeparam.resultdef);
  354. module:=find_module_from_symtable(typeparam.resultdef.owner);
  355. if not assigned(module) then
  356. internalerror(2016112802);
  357. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+typeparam.resultdef.unique_id_str;
  358. { we use the full name of the type to uniquely identify it }
  359. if (symtablestack.top.symtabletype=parasymtable) and
  360. (symtablestack.top.defowner.typ=procdef) and
  361. (typeparam.resultdef.owner=symtablestack.top) then
  362. begin
  363. { special handling for specializations inside generic function declarations }
  364. prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname;
  365. end
  366. else
  367. begin
  368. prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true);
  369. end;
  370. specializename:=specializename+namepart;
  371. if not first then
  372. prettyname:=prettyname+',';
  373. prettyname:=prettyname+prettynamepart+typeparam.resultdef.typesym.prettyname;
  374. end;
  375. end
  376. else
  377. begin
  378. result:=false;
  379. end;
  380. end
  381. else
  382. begin
  383. Message(type_e_type_id_expected);
  384. result:=false;
  385. end;
  386. typeparam.free;
  387. first:=false;
  388. end;
  389. block_type:=old_block_type;
  390. end;
  391. function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  392. var
  393. dummypos : tfileposinfo;
  394. begin
  395. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  396. result:=parse_generic_specialization_types_internal(genericdeflist,poslist,prettyname,specializename,nil,dummypos);
  397. end;
  398. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string);
  399. var
  400. dummypos : tfileposinfo;
  401. begin
  402. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  403. generate_specialization(tt,parse_class_parent,_prettyname,nil,'',dummypos);
  404. end;
  405. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;
  406. var
  407. dummypos : tfileposinfo;
  408. {$push}
  409. {$warn 5036 off}
  410. begin
  411. result:=generate_specialization_phase1(context,genericdef,nil,'',dummypos);
  412. end;
  413. {$pop}
  414. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;
  415. var
  416. dummypos : tfileposinfo;
  417. {$push}
  418. {$warn 5036 off}
  419. begin
  420. result:=generate_specialization_phase1(context,genericdef,nil,symname,dummypos);
  421. end;
  422. {$pop}
  423. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef;
  424. var
  425. pt2 : tnode;
  426. errorrecovery,
  427. found,
  428. first,
  429. err : boolean;
  430. i,
  431. gencount : longint;
  432. def : tstoreddef;
  433. countstr,genname,ugenname : string;
  434. srsym : tsym;
  435. st : tsymtable;
  436. begin
  437. context:=nil;
  438. result:=nil;
  439. { either symname must be given or genericdef needs to be valid }
  440. errorrecovery:=false;
  441. if (symname='') and
  442. (not assigned(genericdef) or
  443. not assigned(genericdef.typesym) or
  444. (genericdef.typesym.typ<>typesym)) then
  445. begin
  446. errorrecovery:=true;
  447. result:=generrordef;
  448. end;
  449. { Only parse the parameters for recovery or
  450. for recording in genericbuf }
  451. if errorrecovery then
  452. begin
  453. first:=assigned(parsedtype);
  454. if not first and not try_to_consume(_LT) then
  455. consume(_LSHARPBRACKET);
  456. gencount:=0;
  457. { handle "<>" }
  458. if not first and ((token=_RSHARPBRACKET) or (token=_GT)) then
  459. Message(type_e_type_id_expected)
  460. else
  461. repeat
  462. if not first then
  463. begin
  464. pt2:=factor(false,[ef_type_only]);
  465. pt2.free;
  466. end;
  467. first:=false;
  468. inc(gencount);
  469. until not try_to_consume(_COMMA);
  470. if not try_to_consume(_GT) then
  471. consume(_RSHARPBRACKET);
  472. { we need to return a def that can later pass some checks like
  473. whether it's an interface or not }
  474. if not errorrecovery and
  475. (not assigned(result) or (result.typ=undefineddef)) then
  476. begin
  477. if (symname='') and tstoreddef(genericdef).is_generic then
  478. { this happens in non-Delphi modes }
  479. result:=genericdef
  480. else
  481. begin
  482. { find the corresponding generic symbol so that any checks
  483. done on the returned def will be handled correctly }
  484. str(gencount,countstr);
  485. if symname='' then
  486. genname:=ttypesym(genericdef.typesym).realname
  487. else
  488. genname:=symname;
  489. genname:=genname+'$'+countstr;
  490. ugenname:=upper(genname);
  491. { first check whether the found name is the same as that of
  492. the current def or one of its (generic) surrounding defs;
  493. this is necessary as the symbol of the generic can not yet
  494. be used for lookup as it still contains a reference to an
  495. errordef) }
  496. def:=current_genericdef;
  497. repeat
  498. if def.typ in [objectdef,recorddef] then
  499. if tabstractrecorddef(def).objname^=ugenname then
  500. begin
  501. result:=def;
  502. break;
  503. end;
  504. def:=tstoreddef(def.owner.defowner);
  505. until not assigned(def) or not (df_generic in def.defoptions);
  506. { it's not part of the current object hierarchy, so search
  507. for the symbol }
  508. if not assigned(result) then
  509. begin
  510. srsym:=nil;
  511. if not searchsym(ugenname,srsym,st) or
  512. (srsym.typ<>typesym) then
  513. begin
  514. identifier_not_found(genname);
  515. result:=generrordef;
  516. exit;
  517. end;
  518. result:=ttypesym(srsym).typedef;
  519. { this happens in non-Delphi modes if we encounter a
  520. specialization of the generic class or record we're
  521. currently parsing }
  522. if (result.typ=errordef) and assigned(current_structdef) and
  523. (current_structdef.objname^=ugenname) then
  524. result:=current_structdef;
  525. end;
  526. end;
  527. end;
  528. exit;
  529. end;
  530. if not assigned(parsedtype) and not try_to_consume(_LT) then
  531. begin
  532. consume(_LSHARPBRACKET);
  533. { handle "<>" }
  534. if (token=_GT) or (token=_RSHARPBRACKET) then
  535. begin
  536. Message(type_e_type_id_expected);
  537. if not try_to_consume(_GT) then
  538. try_to_consume(_RSHARPBRACKET);
  539. result:=generrordef;
  540. exit;
  541. end;
  542. end;
  543. context:=tspecializationcontext.create;
  544. { Parse type parameters }
  545. err:=not parse_generic_specialization_types_internal(context.genericdeflist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos);
  546. if err then
  547. begin
  548. if not try_to_consume(_GT) then
  549. try_to_consume(_RSHARPBRACKET);
  550. context.free;
  551. context:=nil;
  552. result:=generrordef;
  553. exit;
  554. end;
  555. { use the name of the symbol as procvars return a user friendly version
  556. of the name }
  557. if symname='' then
  558. genname:=ttypesym(genericdef.typesym).realname
  559. else
  560. genname:=symname;
  561. { in case of non-Delphi mode the type name could already be a generic
  562. def (but maybe the wrong one) }
  563. if assigned(genericdef) and
  564. ([df_generic,df_specialization]*genericdef.defoptions<>[]) then
  565. begin
  566. { remove the type count suffix from the generic's name }
  567. for i:=Length(genname) downto 1 do
  568. if genname[i]='$' then
  569. begin
  570. genname:=copy(genname,1,i-1);
  571. break;
  572. end;
  573. { in case of a specialization we've only reached the specialization
  574. checksum yet }
  575. if df_specialization in genericdef.defoptions then
  576. for i:=length(genname) downto 1 do
  577. if genname[i]='$' then
  578. begin
  579. genname:=copy(genname,1,i-1);
  580. break;
  581. end;
  582. end
  583. else
  584. begin
  585. split_generic_name(genname,ugenname,gencount);
  586. if genname<>ugenname then
  587. genname:=ugenname;
  588. end;
  589. { search a generic with the given count of params }
  590. countstr:='';
  591. str(context.genericdeflist.Count,countstr);
  592. genname:=genname+'$'+countstr;
  593. ugenname:=upper(genname);
  594. context.genname:=genname;
  595. if assigned(genericdef) and (genericdef.owner.symtabletype in [objectsymtable,recordsymtable]) then
  596. begin
  597. if genericdef.owner.symtabletype = objectsymtable then
  598. found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,context.sym,context.symtable,[])
  599. else
  600. found:=searchsym_in_record(tabstractrecorddef(genericdef.owner.defowner),ugenname,context.sym,context.symtable);
  601. if not found then
  602. found:=searchsym(ugenname,context.sym,context.symtable);
  603. end
  604. else
  605. found:=searchsym(ugenname,context.sym,context.symtable);
  606. if not found or not (context.sym.typ in [typesym,procsym]) then
  607. begin
  608. identifier_not_found(genname);
  609. if not try_to_consume(_GT) then
  610. try_to_consume(_RSHARPBRACKET);
  611. context.free;
  612. context:=nil;
  613. result:=generrordef;
  614. exit;
  615. end;
  616. { we've found the correct def }
  617. if context.sym.typ=typesym then
  618. result:=tstoreddef(ttypesym(context.sym).typedef)
  619. else
  620. begin
  621. if tprocsym(context.sym).procdeflist.count=0 then
  622. internalerror(2015061203);
  623. result:=tstoreddef(tprocsym(context.sym).procdefList[0]);
  624. end;
  625. if not try_to_consume(_GT) then
  626. consume(_RSHARPBRACKET);
  627. end;
  628. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef;
  629. procedure unset_forwarddef(def: tdef);
  630. var
  631. st : TSymtable;
  632. i : longint;
  633. begin
  634. case def.typ of
  635. procdef:
  636. tprocdef(def).forwarddef:=false;
  637. objectdef,
  638. recorddef:
  639. begin
  640. st:=def.getsymtable(gs_record);
  641. for i:=0 to st.deflist.count-1 do
  642. unset_forwarddef(tdef(st.deflist[i]));
  643. end;
  644. else
  645. ;
  646. end;
  647. end;
  648. procedure retrieve_genericdef_or_procsym(sym:tsym;out gendef:tdef;out psym:tsym);
  649. var
  650. i : longint;
  651. begin
  652. gendef:=nil;
  653. psym:=nil;
  654. case sym.typ of
  655. typesym:
  656. begin
  657. gendef:=ttypesym(sym).typedef
  658. end;
  659. procsym:
  660. begin
  661. for i:=0 to tprocsym(sym).procdeflist.count-1 do
  662. if tstoreddef(tprocsym(sym).procdeflist[i]).genericdef=genericdef then
  663. begin
  664. gendef:=tdef(tprocsym(sym).procdeflist[i]);
  665. break;
  666. end;
  667. psym:=sym;
  668. end
  669. else
  670. internalerror(200710171);
  671. end;
  672. end;
  673. var
  674. finalspecializename,
  675. ufinalspecializename : tidstring;
  676. prettyname : ansistring;
  677. generictypelist : tfphashobjectlist;
  678. srsymtable,
  679. specializest : tsymtable;
  680. hashedid : thashedidstring;
  681. tempst : tglobalsymtable;
  682. psym,
  683. srsym : tsym;
  684. def : tdef;
  685. old_block_type : tblock_type;
  686. state : tspecializationstate;
  687. old_current_structdef : tabstractrecorddef;
  688. old_current_specializedef,
  689. old_current_genericdef : tstoreddef;
  690. old_current_procinfo : tprocinfo;
  691. hmodule : tmodule;
  692. oldcurrent_filepos : tfileposinfo;
  693. recordbuf : tdynamicarray;
  694. hadtypetoken : boolean;
  695. vmtbuilder : tvmtbuilder;
  696. i,
  697. replaydepth : longint;
  698. item : tobject;
  699. allequal,
  700. hintsprocessed : boolean;
  701. pd : tprocdef;
  702. pdflags : tpdflags;
  703. begin
  704. if not assigned(context) then
  705. internalerror(2015052203);
  706. result:=nil;
  707. pd:=nil;
  708. if not check_generic_constraints(genericdef,context.genericdeflist,context.poslist) then
  709. begin
  710. { the parameters didn't fit the constraints, so don't continue with the
  711. specialization }
  712. result:=generrordef;
  713. exit;
  714. end;
  715. { build the new type's name }
  716. finalspecializename:=generate_generic_name(context.genname,context.specializename,genericdef.ownerhierarchyname);
  717. ufinalspecializename:=upper(finalspecializename);
  718. if genericdef.typ=procdef then
  719. prettyname:=tprocdef(genericdef).procsym.prettyname
  720. else
  721. prettyname:=genericdef.typesym.prettyname;
  722. prettyname:=prettyname+'<'+context.prettyname+'>';
  723. generictypelist:=tfphashobjectlist.create(false);
  724. { build the list containing the types for the generic params }
  725. if not assigned(genericdef.genericparas) then
  726. internalerror(2013092601);
  727. if context.genericdeflist.count<>genericdef.genericparas.count then
  728. internalerror(2013092603);
  729. for i:=0 to genericdef.genericparas.Count-1 do
  730. begin
  731. srsym:=tsym(genericdef.genericparas[i]);
  732. if not (sp_generic_para in srsym.symoptions) then
  733. internalerror(2013092602);
  734. generictypelist.add(srsym.realname,tdef(context.genericdeflist[i]).typesym);
  735. end;
  736. { Special case if we are referencing the current defined object }
  737. if assigned(current_structdef) and
  738. (current_structdef.objname^=ufinalspecializename) then
  739. result:=current_structdef;
  740. { Can we reuse an already specialized type? }
  741. { for this first check whether we are currently specializing a nested
  742. type of the current (main) specialization (this is necessary, because
  743. during that time the symbol of the main specialization will still
  744. contain a reference to an errordef) }
  745. if not assigned(result) and assigned(current_specializedef) then
  746. begin
  747. def:=current_specializedef;
  748. repeat
  749. if def.typ in [objectdef,recorddef] then
  750. if tabstractrecorddef(def).objname^=ufinalspecializename then begin
  751. result:=def;
  752. break;
  753. end;
  754. if assigned(def.owner) then
  755. def:=tstoreddef(def.owner.defowner)
  756. else
  757. { this can happen when specializing a generic function }
  758. def:=nil;
  759. until not assigned(def) or not (df_specialization in def.defoptions);
  760. end;
  761. { if the genericdef is the def we are currently parsing (or one of its parents) then we can
  762. not use it for specializing as the tokenbuffer is not yet set (and we aren't done with
  763. parsing anyway), so for now we treat those still as generic defs without doing a partial
  764. specialization }
  765. if not assigned(result) then
  766. begin
  767. def:=current_genericdef;
  768. while assigned(def) and (def.typ in [recorddef,objectdef]) do
  769. begin
  770. if (df_generic in def.defoptions) and (def=genericdef) then
  771. begin
  772. result:=def;
  773. break;
  774. end;
  775. { the following happens when a routine with its parent struct
  776. as parameter is specialized as a parameter or result of a
  777. generic function }
  778. if (df_specialization in def.defoptions) and (tstoreddef(def).genericdef=genericdef) then
  779. begin
  780. if tstoreddef(def).genericparas.count=generictypelist.count then
  781. begin
  782. allequal:=true;
  783. for i:=0 to generictypelist.count-1 do
  784. begin
  785. if not equal_defs(ttypesym(generictypelist[i]).typedef,ttypesym(tstoreddef(def).genericparas[i]).typedef) then
  786. begin
  787. allequal:=false;
  788. break;
  789. end;
  790. end;
  791. if allequal then
  792. begin
  793. result:=def;
  794. break;
  795. end;
  796. end;
  797. end;
  798. def:=tstoreddef(def.owner.defowner);
  799. end;
  800. end;
  801. { decide in which symtable to put the specialization }
  802. if parse_generic and not assigned(result) then
  803. begin
  804. if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
  805. { if we are parsing the definition of a method we specialize into
  806. the local symtable of it }
  807. specializest:=current_procinfo.procdef.getsymtable(gs_local)
  808. else
  809. begin
  810. if not assigned(current_genericdef) then
  811. internalerror(2014050901);
  812. { we specialize the partial specialization into the symtable of the currently parsed
  813. generic }
  814. case current_genericdef.typ of
  815. procvardef:
  816. specializest:=current_genericdef.getsymtable(gs_para);
  817. procdef:
  818. specializest:=current_genericdef.getsymtable(gs_local);
  819. objectdef,
  820. recorddef:
  821. specializest:=current_genericdef.getsymtable(gs_record);
  822. arraydef:
  823. specializest:=tarraydef(current_genericdef).symtable;
  824. else
  825. internalerror(2014050902);
  826. end;
  827. end;
  828. end
  829. else
  830. if current_module.is_unit and current_module.in_interface then
  831. specializest:=current_module.globalsymtable
  832. else
  833. specializest:=current_module.localsymtable;
  834. if not assigned(specializest) then
  835. internalerror(2014050910);
  836. { now check whether there is a specialization somewhere else }
  837. psym:=nil;
  838. if not assigned(result) then
  839. begin
  840. hashedid.id:=ufinalspecializename;
  841. if specializest.symtabletype=objectsymtable then
  842. begin
  843. { search also in parent classes }
  844. if not assigned(current_genericdef) or (current_genericdef.typ<>objectdef) then
  845. internalerror(2016112901);
  846. if not searchsym_in_class(tobjectdef(current_genericdef),tobjectdef(current_genericdef),ufinalspecializename,srsym,srsymtable,[]) then
  847. srsym:=nil;
  848. end
  849. else
  850. srsym:=tsym(specializest.findwithhash(hashedid));
  851. if assigned(srsym) then
  852. begin
  853. retrieve_genericdef_or_procsym(srsym,result,psym);
  854. end
  855. else
  856. { the generic could have been specialized in the globalsymtable
  857. already, so search there as well }
  858. if (specializest<>current_module.globalsymtable) and assigned(current_module.globalsymtable) then
  859. begin
  860. srsym:=tsym(current_module.globalsymtable.findwithhash(hashedid));
  861. if assigned(srsym) then
  862. begin
  863. retrieve_genericdef_or_procsym(srsym,result,psym);
  864. end;
  865. end;
  866. end;
  867. if not assigned(result) then
  868. begin
  869. specialization_init(genericdef,state);
  870. { push a temporary global symtable so that the specialization is
  871. added to the correct symtable; this symtable does not contain
  872. any other symbols, so that the type resolution can not be
  873. influenced by symbols in the current unit }
  874. tempst:=tspecializesymtable.create(current_module.modulename^,current_module.moduleid);
  875. symtablestack.push(tempst);
  876. { Reparse the original type definition }
  877. begin
  878. old_current_specializedef:=nil;
  879. old_current_genericdef:=nil;
  880. old_current_structdef:=nil;
  881. old_current_procinfo:=current_procinfo;
  882. current_procinfo:=nil;
  883. if parse_class_parent then
  884. begin
  885. old_current_structdef:=current_structdef;
  886. old_current_genericdef:=current_genericdef;
  887. old_current_specializedef:=current_specializedef;
  888. if genericdef.owner.symtabletype in [recordsymtable,objectsymtable] then
  889. current_structdef:=tabstractrecorddef(genericdef.owner.defowner)
  890. else
  891. current_structdef:=nil;
  892. current_genericdef:=nil;
  893. current_specializedef:=nil;
  894. end;
  895. maybe_add_waiting_unit(genericdef);
  896. { First a new sym so we can reuse this specialization and
  897. references to this specialization can be handled }
  898. if genericdef.typ=procdef then
  899. if assigned(psym) then
  900. srsym:=psym
  901. else
  902. srsym:=cprocsym.create(finalspecializename)
  903. else
  904. srsym:=ctypesym.create(finalspecializename,generrordef,true);
  905. { insert the symbol only if we don't know already that we have
  906. a procsym to add it to }
  907. if not assigned(psym) then
  908. specializest.insert(srsym);
  909. { specializations are declarations as such it is the wisest to
  910. declare set the blocktype to "type"; otherwise we'll
  911. experience unexpected side effects like the addition of
  912. classrefdefs if we have a generic that's derived from another
  913. generic }
  914. old_block_type:=block_type;
  915. block_type:=bt_type;
  916. if (
  917. (genericdef.typ=procdef) and
  918. not assigned(tprocdef(genericdef).genericdecltokenbuf)
  919. ) or (
  920. (genericdef.typ<>procdef) and
  921. not assigned(genericdef.generictokenbuf)
  922. ) then
  923. internalerror(200511171);
  924. hmodule:=find_module_from_symtable(genericdef.owner);
  925. if hmodule=nil then
  926. internalerror(2012051202);
  927. oldcurrent_filepos:=current_filepos;
  928. { use the index the module got from the current compilation process }
  929. current_filepos.moduleindex:=hmodule.unit_index;
  930. current_tokenpos:=current_filepos;
  931. if parse_generic then
  932. begin
  933. recordbuf:=current_scanner.recordtokenbuf;
  934. current_scanner.recordtokenbuf:=nil;
  935. end
  936. else
  937. recordbuf:=nil;
  938. replaydepth:=current_scanner.replay_stack_depth;
  939. if genericdef.typ=procdef then
  940. begin
  941. current_scanner.startreplaytokens(tprocdef(genericdef).genericdecltokenbuf);
  942. parse_proc_head(tprocdef(genericdef).struct,tprocdef(genericdef).proctypeoption,false,genericdef,generictypelist,pd);
  943. if assigned(pd) then
  944. begin
  945. if assigned(psym) then
  946. pd.procsym:=psym
  947. else
  948. pd.procsym:=srsym;
  949. parse_proc_dec_finish(pd,po_classmethod in tprocdef(genericdef).procoptions,tprocdef(genericdef).struct);
  950. end;
  951. result:=pd;
  952. end
  953. else
  954. begin
  955. current_scanner.startreplaytokens(genericdef.generictokenbuf);
  956. hadtypetoken:=false;
  957. read_named_type(result,srsym,genericdef,generictypelist,false,hadtypetoken);
  958. ttypesym(srsym).typedef:=result;
  959. result.typesym:=srsym;
  960. if _prettyname<>'' then
  961. ttypesym(result.typesym).fprettyname:=_prettyname
  962. else
  963. ttypesym(result.typesym).fprettyname:=prettyname;
  964. end;
  965. current_filepos:=oldcurrent_filepos;
  966. { Note regarding hint directives:
  967. There is no need to remove the flags for them from the
  968. specialized generic symbol, because hint directives that
  969. follow the specialization are handled by the code in
  970. pdecl.types_dec and added to the type symbol.
  971. E.g.: TFoo = TBar<Blubb> deprecated;
  972. Here the symbol TBar$1$Blubb will contain the
  973. "sp_hint_deprecated" flag while the TFoo symbol won't.}
  974. case result.typ of
  975. { Build VMT indexes for classes and read hint directives }
  976. objectdef:
  977. begin
  978. if replaydepth>current_scanner.replay_stack_depth then
  979. begin
  980. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  981. if replaydepth>current_scanner.replay_stack_depth then
  982. consume(_SEMICOLON);
  983. end;
  984. vmtbuilder:=TVMTBuilder.Create(tobjectdef(result));
  985. vmtbuilder.generate_vmt;
  986. vmtbuilder.free;
  987. end;
  988. { handle params, calling convention, etc }
  989. procvardef:
  990. begin
  991. hintsprocessed:=false;
  992. if replaydepth>current_scanner.replay_stack_depth then
  993. begin
  994. if not check_proc_directive(true) then
  995. begin
  996. hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  997. if replaydepth>current_scanner.replay_stack_depth then
  998. consume(_SEMICOLON);
  999. end
  1000. else
  1001. hintsprocessed:=true;
  1002. end;
  1003. if replaydepth>current_scanner.replay_stack_depth then
  1004. parse_var_proc_directives(ttypesym(srsym));
  1005. handle_calling_convention(tprocvardef(result),hcc_default_actions_intf);
  1006. if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then
  1007. begin
  1008. try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  1009. if replaydepth>current_scanner.replay_stack_depth then
  1010. consume(_SEMICOLON);
  1011. end;
  1012. end;
  1013. procdef:
  1014. begin
  1015. pdflags:=[pd_body,pd_implemen];
  1016. if genericdef.owner.symtabletype=objectsymtable then
  1017. include(pdflags,pd_object)
  1018. else if genericdef.owner.symtabletype=recordsymtable then
  1019. include(pdflags,pd_record);
  1020. parse_proc_directives(pd,pdflags);
  1021. while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
  1022. consume(_SEMICOLON);
  1023. if parse_generic then
  1024. handle_calling_convention(tprocdef(result),hcc_default_actions_intf)
  1025. else
  1026. handle_calling_convention(tprocdef(result),hcc_default_actions_impl);
  1027. proc_add_definition(tprocdef(result));
  1028. { for partial specializations we implicitely declare the routine as
  1029. having its implementation although we'll not specialize it in reality }
  1030. if parse_generic then
  1031. unset_forwarddef(result);
  1032. end;
  1033. else
  1034. { parse hint directives for records and arrays }
  1035. if replaydepth>current_scanner.replay_stack_depth then begin
  1036. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  1037. if replaydepth>current_scanner.replay_stack_depth then
  1038. consume(_SEMICOLON);
  1039. end;
  1040. end;
  1041. { Consume the remainder of the buffer }
  1042. while current_scanner.replay_stack_depth>replaydepth do
  1043. consume(token);
  1044. if assigned(recordbuf) then
  1045. begin
  1046. if assigned(current_scanner.recordtokenbuf) then
  1047. internalerror(2014050909);
  1048. current_scanner.recordtokenbuf:=recordbuf;
  1049. end;
  1050. block_type:=old_block_type;
  1051. current_procinfo:=old_current_procinfo;
  1052. if parse_class_parent then
  1053. begin
  1054. current_structdef:=old_current_structdef;
  1055. current_genericdef:=old_current_genericdef;
  1056. current_specializedef:=old_current_specializedef;
  1057. end;
  1058. end;
  1059. { extract all created symbols and defs from the temporary symtable
  1060. and add them to the specializest }
  1061. for i:=tempst.SymList.Count-1 downto 0 do
  1062. begin
  1063. item:=tempst.SymList.Items[i];
  1064. { using changeowner the symbol is automatically added to the
  1065. new symtable }
  1066. tsym(item).ChangeOwner(specializest);
  1067. end;
  1068. for i:=tempst.DefList.Count-1 downto 0 do
  1069. begin
  1070. item:=tempst.DefList.Items[i];
  1071. { using changeowner the def is automatically added to the new
  1072. symtable }
  1073. tdef(item).ChangeOwner(specializest);
  1074. { for partial specializations we implicitely declare any methods as having their
  1075. implementations although we'll not specialize them in reality }
  1076. if parse_generic then
  1077. unset_forwarddef(tdef(item));
  1078. end;
  1079. { if a generic was declared during the specialization we need to
  1080. flag the specialize symtable accordingly }
  1081. if sto_has_generic in tempst.tableoptions then
  1082. specializest.includeoption(sto_has_generic);
  1083. tempst.free;
  1084. specialization_done(state);
  1085. { procdefs are only added once we know which overload we use }
  1086. if not parse_generic and (result.typ<>procdef) then
  1087. current_module.pendingspecializations.add(result.typename,result);
  1088. end;
  1089. generictypelist.free;
  1090. if assigned(genericdef) then
  1091. begin
  1092. { check the hints of the found generic symbol }
  1093. if genericdef.typ=procdef then
  1094. srsym:=tprocdef(genericdef).procsym
  1095. else
  1096. srsym:=genericdef.typesym;
  1097. check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
  1098. end;
  1099. end;
  1100. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string;parsedpos:tfileposinfo);
  1101. var
  1102. context : tspecializationcontext;
  1103. genericdef : tstoreddef;
  1104. begin
  1105. genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,parsedpos));
  1106. if genericdef<>generrordef then
  1107. genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname));
  1108. tt:=genericdef;
  1109. if assigned(context) then
  1110. context.free;
  1111. end;
  1112. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  1113. var
  1114. generictype : ttypesym;
  1115. i,firstidx : longint;
  1116. srsymtable : tsymtable;
  1117. basedef,def : tdef;
  1118. defname : tidstring;
  1119. allowconstructor,
  1120. doconsume : boolean;
  1121. constraintdata : tgenericconstraintdata;
  1122. old_block_type : tblock_type;
  1123. begin
  1124. result:=tfphashobjectlist.create(false);
  1125. firstidx:=0;
  1126. old_block_type:=block_type;
  1127. block_type:=bt_type;
  1128. repeat
  1129. if token=_ID then
  1130. begin
  1131. generictype:=ctypesym.create(orgpattern,cundefinedtype,false);
  1132. { type parameters need to be added as strict private }
  1133. generictype.visibility:=vis_strictprivate;
  1134. include(generictype.symoptions,sp_generic_para);
  1135. result.add(orgpattern,generictype);
  1136. end;
  1137. consume(_ID);
  1138. if try_to_consume(_COLON) then
  1139. begin
  1140. if not allowconstraints then
  1141. { TODO }
  1142. Message(parser_e_illegal_expression{ parser_e_generic_constraints_not_allowed_here});
  1143. { construct a name which can be used for a type specification }
  1144. constraintdata:=tgenericconstraintdata.create;
  1145. defname:='';
  1146. str(current_module.deflist.count,defname);
  1147. defname:='$gendef'+defname;
  1148. allowconstructor:=m_delphi in current_settings.modeswitches;
  1149. basedef:=generrordef;
  1150. repeat
  1151. doconsume:=true;
  1152. case token of
  1153. _CONSTRUCTOR:
  1154. begin
  1155. if not allowconstructor or (gcf_constructor in constraintdata.flags) then
  1156. Message(parser_e_illegal_expression);
  1157. include(constraintdata.flags,gcf_constructor);
  1158. allowconstructor:=false;
  1159. end;
  1160. _CLASS:
  1161. begin
  1162. if gcf_class in constraintdata.flags then
  1163. Message(parser_e_illegal_expression);
  1164. if basedef=generrordef then
  1165. include(constraintdata.flags,gcf_class)
  1166. else
  1167. Message(parser_e_illegal_expression);
  1168. end;
  1169. _RECORD:
  1170. begin
  1171. if ([gcf_constructor,gcf_class]*constraintdata.flags<>[])
  1172. or (constraintdata.interfaces.count>0) then
  1173. Message(parser_e_illegal_expression)
  1174. else
  1175. begin
  1176. srsymtable:=trecordsymtable.create(defname,0,1);
  1177. basedef:=crecorddef.create(defname,srsymtable);
  1178. include(constraintdata.flags,gcf_record);
  1179. allowconstructor:=false;
  1180. end;
  1181. end;
  1182. else
  1183. begin
  1184. { after single_type "token" is the trailing ",", ";" or
  1185. ">"! }
  1186. doconsume:=false;
  1187. { def is already set to a class or record }
  1188. if gcf_record in constraintdata.flags then
  1189. Message(parser_e_illegal_expression);
  1190. single_type(def, [stoAllowSpecialization]);
  1191. { only types that are inheritable are allowed }
  1192. if (def.typ<>objectdef) or
  1193. not (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_javaclass]) then
  1194. Message1(type_e_class_or_interface_type_expected,def.typename)
  1195. else
  1196. case tobjectdef(def).objecttype of
  1197. odt_class,
  1198. odt_javaclass:
  1199. begin
  1200. if gcf_class in constraintdata.flags then
  1201. { "class" + concrete class is not allowed }
  1202. Message(parser_e_illegal_expression)
  1203. else
  1204. { do we already have a concrete class? }
  1205. if basedef<>generrordef then
  1206. Message(parser_e_illegal_expression)
  1207. else
  1208. basedef:=def;
  1209. end;
  1210. odt_interfacecom,
  1211. odt_interfacecorba,
  1212. odt_interfacejava,
  1213. odt_dispinterface:
  1214. constraintdata.interfaces.add(def);
  1215. else
  1216. ;
  1217. end;
  1218. end;
  1219. end;
  1220. if doconsume then
  1221. consume(token);
  1222. until not try_to_consume(_COMMA);
  1223. if ([gcf_class,gcf_constructor]*constraintdata.flags<>[]) or
  1224. (constraintdata.interfaces.count>1) or
  1225. (
  1226. (basedef.typ=objectdef) and
  1227. (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class])
  1228. ) then
  1229. begin
  1230. if basedef.typ=errordef then
  1231. { don't pass an errordef as a parent to a tobjectdef }
  1232. basedef:=class_tobject
  1233. else
  1234. if (basedef.typ<>objectdef) or
  1235. not (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class]) then
  1236. internalerror(2012101101);
  1237. basedef:=cobjectdef.create(tobjectdef(basedef).objecttype,defname,tobjectdef(basedef),false);
  1238. for i:=0 to constraintdata.interfaces.count-1 do
  1239. tobjectdef(basedef).implementedinterfaces.add(
  1240. timplementedinterface.create(tobjectdef(constraintdata.interfaces[i])));
  1241. end
  1242. else
  1243. if constraintdata.interfaces.count=1 then
  1244. begin
  1245. if basedef.typ<>errordef then
  1246. internalerror(2013021601);
  1247. def:=tdef(constraintdata.interfaces[0]);
  1248. basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false);
  1249. constraintdata.interfaces.delete(0);
  1250. end;
  1251. if basedef.typ<>errordef then
  1252. with tstoreddef(basedef) do
  1253. begin
  1254. genconstraintdata:=tgenericconstraintdata.create;
  1255. genconstraintdata.flags:=constraintdata.flags;
  1256. genconstraintdata.interfaces.assign(constraintdata.interfaces);
  1257. include(defoptions,df_genconstraint);
  1258. end;
  1259. for i:=firstidx to result.count-1 do
  1260. ttypesym(result[i]).typedef:=basedef;
  1261. { we need a typesym in case we do a Delphi-mode inline
  1262. specialization with this parameter; so just use the first sym }
  1263. if not assigned(basedef.typesym) then
  1264. basedef.typesym:=ttypesym(result[firstidx]);
  1265. firstidx:=result.count;
  1266. constraintdata.free;
  1267. end
  1268. else
  1269. begin
  1270. if token=_SEMICOLON then
  1271. begin
  1272. { two different typeless parameters are considered as incompatible }
  1273. for i:=firstidx to result.count-1 do
  1274. begin
  1275. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  1276. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  1277. end;
  1278. { a semicolon terminates a type parameter group }
  1279. firstidx:=result.count;
  1280. end;
  1281. end;
  1282. until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON));
  1283. { two different typeless parameters are considered as incompatible }
  1284. for i:=firstidx to result.count-1 do
  1285. begin
  1286. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  1287. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  1288. end;
  1289. block_type:=old_block_type;
  1290. end;
  1291. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
  1292. var
  1293. i : longint;
  1294. generictype,sym : ttypesym;
  1295. st : tsymtable;
  1296. begin
  1297. def.genericdef:=genericdef;
  1298. if not assigned(genericlist) then
  1299. exit;
  1300. if assigned(genericdef) then
  1301. include(def.defoptions,df_specialization)
  1302. else
  1303. if genericlist.count>0 then
  1304. include(def.defoptions,df_generic);
  1305. case def.typ of
  1306. recorddef,objectdef: st:=tabstractrecorddef(def).symtable;
  1307. arraydef: st:=tarraydef(def).symtable;
  1308. procvardef,procdef: st:=tabstractprocdef(def).parast;
  1309. else
  1310. internalerror(201101020);
  1311. end;
  1312. if (genericlist.count>0) and not assigned(def.genericparas) then
  1313. def.genericparas:=tfphashobjectlist.create(false);
  1314. for i:=0 to genericlist.count-1 do
  1315. begin
  1316. generictype:=ttypesym(genericlist[i]);
  1317. if assigned(generictype.owner) then
  1318. begin
  1319. sym:=ctypesym.create(genericlist.nameofindex(i),generictype.typedef,true);
  1320. { type parameters need to be added as strict private }
  1321. sym.visibility:=vis_strictprivate;
  1322. st.insert(sym);
  1323. include(sym.symoptions,sp_generic_para);
  1324. end
  1325. else
  1326. begin
  1327. if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then
  1328. begin
  1329. { the generic parameters were parsed before the genericdef existed thus the
  1330. undefineddefs were added as part of the parent symtable }
  1331. if assigned(generictype.typedef.owner) then
  1332. generictype.typedef.owner.DefList.Extract(generictype.typedef);
  1333. generictype.typedef.changeowner(st);
  1334. end;
  1335. st.insert(generictype);
  1336. include(generictype.symoptions,sp_generic_para);
  1337. end;
  1338. def.genericparas.add(genericlist.nameofindex(i),generictype);
  1339. end;
  1340. end;
  1341. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  1342. var
  1343. gensym : ttypesym;
  1344. begin
  1345. { for generics in non-Delphi modes we insert a private type symbol
  1346. that has the same base name as the currently parsed generic and
  1347. that references this defs }
  1348. if not (m_delphi in current_settings.modeswitches) and
  1349. (
  1350. (
  1351. parse_generic and
  1352. assigned(genericlist) and
  1353. (genericlist.count>0)
  1354. ) or
  1355. (
  1356. assigned(current_specializedef) and
  1357. assigned(current_structdef.genericdef) and
  1358. (current_structdef.genericdef.typ in [objectdef,recorddef]) and
  1359. (pos('$',name)>0)
  1360. )
  1361. ) then
  1362. begin
  1363. { we need to pass nil as def here, because the constructor wants
  1364. to set the typesym of the def which is not what we want }
  1365. gensym:=ctypesym.create(copy(name,1,pos('$',name)-1),nil,true);
  1366. gensym.typedef:=current_structdef;
  1367. include(gensym.symoptions,sp_internal);
  1368. { the symbol should be only visible to the generic class
  1369. itself }
  1370. gensym.visibility:=vis_strictprivate;
  1371. symtablestack.top.insert(gensym);
  1372. end;
  1373. end;
  1374. function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring;
  1375. var
  1376. crc : cardinal;
  1377. begin
  1378. if specializename='' then
  1379. internalerror(2012061901);
  1380. { build the new type's name }
  1381. crc:=UpdateCrc32(0,specializename[1],length(specializename));
  1382. result:=name+'$crc'+hexstr(crc,8);
  1383. if owner_hierarchy<>'' then
  1384. begin
  1385. crc:=UpdateCrc32(0,owner_hierarchy[1],length(owner_hierarchy));
  1386. result:=result+'$crc'+hexstr(crc,8);
  1387. end;
  1388. end;
  1389. procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
  1390. var
  1391. i,code : longint;
  1392. countstr : string;
  1393. begin
  1394. for i:=length(name) downto 1 do
  1395. if name[i]='$' then
  1396. begin
  1397. nongeneric:=copy(name,1,i-1);
  1398. countstr:=copy(name,i+1,length(name)-i);
  1399. val(countstr,count,code);
  1400. if code<>0 then
  1401. break;
  1402. exit;
  1403. end;
  1404. nongeneric:=name;
  1405. count:=0;
  1406. end;
  1407. procedure add_generic_dummysym(sym:tsym);
  1408. var
  1409. list: TFPObjectList;
  1410. srsym : tsym;
  1411. srsymtable : tsymtable;
  1412. entry : tgenericdummyentry;
  1413. begin
  1414. if sp_generic_dummy in sym.symoptions then
  1415. begin
  1416. { did we already search for a generic with that name? }
  1417. list:=tfpobjectlist(current_module.genericdummysyms.find(sym.name));
  1418. if not assigned(list) then
  1419. begin
  1420. list:=tfpobjectlist.create(true);
  1421. current_module.genericdummysyms.add(sym.name,list);
  1422. end;
  1423. { is the dummy sym still "dummy"? }
  1424. if (sym.typ=typesym) and
  1425. (
  1426. { dummy sym defined in mode Delphi }
  1427. (ttypesym(sym).typedef.typ=undefineddef) or
  1428. { dummy sym defined in non-Delphi mode }
  1429. (tstoreddef(ttypesym(sym).typedef).is_generic)
  1430. ) then
  1431. begin
  1432. { do we have a non-generic type of the same name
  1433. available? }
  1434. if not searchsym_with_flags(sym.name,srsym,srsymtable,[ssf_no_addsymref]) then
  1435. srsym:=nil;
  1436. end
  1437. else if (sym.typ=procsym) and
  1438. (tprocsym(sym).procdeflist.count>0) then
  1439. srsym:=sym
  1440. else
  1441. { dummy symbol is already not so dummy anymore }
  1442. srsym:=nil;
  1443. if assigned(srsym) then
  1444. begin
  1445. entry:=tgenericdummyentry.create;
  1446. entry.resolvedsym:=srsym;
  1447. entry.dummysym:=sym;
  1448. list.add(entry);
  1449. end;
  1450. end;
  1451. end;
  1452. function resolve_generic_dummysym(const name:tidstring):tsym;
  1453. var
  1454. list : tfpobjectlist;
  1455. begin
  1456. list:=tfpobjectlist(current_module.genericdummysyms.find(name));
  1457. if assigned(list) and (list.count>0) then
  1458. result:=tgenericdummyentry(list.last).resolvedsym
  1459. else
  1460. result:=nil;
  1461. end;
  1462. function could_be_generic(const name:tidstring):boolean;
  1463. begin
  1464. result:=(name<>'') and
  1465. (current_module.genericdummysyms.findindexof(name)>=0);
  1466. end;
  1467. procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
  1468. var
  1469. pu : tused_unit;
  1470. hmodule : tmodule;
  1471. unitsyms : TFPHashObjectList;
  1472. sym : tsym;
  1473. i : Integer;
  1474. begin
  1475. if not assigned(genericdef) then
  1476. internalerror(200705151);
  1477. { Setup symtablestack at definition time
  1478. to get types right, however this is not perfect, we should probably record
  1479. the resolved symbols }
  1480. state.oldsymtablestack:=symtablestack;
  1481. state.oldextendeddefs:=current_module.extendeddefs;
  1482. state.oldgenericdummysyms:=current_module.genericdummysyms;
  1483. current_module.extendeddefs:=TFPHashObjectList.create(true);
  1484. current_module.genericdummysyms:=tfphashobjectlist.create(true);
  1485. symtablestack:=tdefawaresymtablestack.create;
  1486. hmodule:=find_module_from_symtable(genericdef.owner);
  1487. if hmodule=nil then
  1488. internalerror(200705152);
  1489. { collect all unit syms in the generic's unit as we need to establish
  1490. their unitsym.module link again so that unit identifiers can be used }
  1491. unitsyms:=tfphashobjectlist.create(false);
  1492. if (hmodule<>current_module) and assigned(hmodule.globalsymtable) then
  1493. for i:=0 to hmodule.globalsymtable.symlist.count-1 do
  1494. begin
  1495. sym:=tsym(hmodule.globalsymtable.symlist[i]);
  1496. if sym.typ=unitsym then
  1497. unitsyms.add(upper(sym.realname),sym);
  1498. end;
  1499. { add all units if we are specializing inside the current unit (as the
  1500. generic could have been declared in the implementation part), but load
  1501. only interface units, if we are in a different unit as then the generic
  1502. needs to be in the interface section }
  1503. pu:=tused_unit(hmodule.used_units.first);
  1504. while assigned(pu) do
  1505. begin
  1506. if not assigned(pu.u.globalsymtable) then
  1507. { in certain circular, but valid unit constellations it can happen
  1508. that we specialize a generic in a different unit that was used
  1509. in the implementation section of the generic's unit and were the
  1510. interface is still being parsed and thus the localsymtable is in
  1511. reality the global symtable }
  1512. if pu.u.in_interface then
  1513. symtablestack.push(pu.u.localsymtable)
  1514. else
  1515. internalerror(200705153)
  1516. else
  1517. symtablestack.push(pu.u.globalsymtable);
  1518. sym:=tsym(unitsyms.find(pu.u.modulename^));
  1519. if assigned(sym) and not assigned(tunitsym(sym).module) then
  1520. tunitsym(sym).module:=pu.u;
  1521. pu:=tused_unit(pu.next);
  1522. end;
  1523. unitsyms.free;
  1524. if assigned(hmodule.globalsymtable) then
  1525. symtablestack.push(hmodule.globalsymtable);
  1526. { push the localsymtable if needed }
  1527. if ((hmodule<>current_module) or not current_module.in_interface)
  1528. and assigned(hmodule.localsymtable) then
  1529. symtablestack.push(hmodule.localsymtable);
  1530. end;
  1531. procedure specialization_done(var state: tspecializationstate);
  1532. begin
  1533. { Restore symtablestack }
  1534. current_module.extendeddefs.free;
  1535. current_module.extendeddefs:=state.oldextendeddefs;
  1536. current_module.genericdummysyms.free;
  1537. current_module.genericdummysyms:=state.oldgenericdummysyms;
  1538. symtablestack.free;
  1539. symtablestack:=state.oldsymtablestack;
  1540. { clear the state record to be on the safe side }
  1541. fillchar(state, sizeof(state), 0);
  1542. end;
  1543. {****************************************************************************
  1544. SPECIALIZATION BODY GENERATION
  1545. ****************************************************************************}
  1546. procedure process_procdef(def:tprocdef;hmodule:tmodule);
  1547. var
  1548. oldcurrent_filepos : tfileposinfo;
  1549. begin
  1550. if assigned(def.genericdef) and
  1551. (def.genericdef.typ=procdef) and
  1552. assigned(tprocdef(def.genericdef).generictokenbuf) then
  1553. begin
  1554. if not assigned(tprocdef(def.genericdef).generictokenbuf) then
  1555. internalerror(2015061902);
  1556. oldcurrent_filepos:=current_filepos;
  1557. current_filepos:=tprocdef(def.genericdef).fileinfo;
  1558. { use the index the module got from the current compilation process }
  1559. current_filepos.moduleindex:=hmodule.unit_index;
  1560. current_tokenpos:=current_filepos;
  1561. current_scanner.startreplaytokens(tprocdef(def.genericdef).generictokenbuf);
  1562. read_proc_body(def);
  1563. current_filepos:=oldcurrent_filepos;
  1564. end
  1565. { synthetic routines will be implemented afterwards }
  1566. else if def.synthetickind=tsk_none then
  1567. MessagePos1(def.fileinfo,sym_e_forward_not_resolved,def.fullprocname(false));
  1568. end;
  1569. function process_abstractrecorddef(def:tabstractrecorddef):boolean;
  1570. var
  1571. i : longint;
  1572. hp : tdef;
  1573. hmodule : tmodule;
  1574. begin
  1575. result:=true;
  1576. hmodule:=find_module_from_symtable(def.genericdef.owner);
  1577. if hmodule=nil then
  1578. internalerror(201202041);
  1579. for i:=0 to def.symtable.DefList.Count-1 do
  1580. begin
  1581. hp:=tdef(def.symtable.DefList[i]);
  1582. if hp.typ=procdef then
  1583. begin
  1584. { only generate the code if we need a body }
  1585. if assigned(tprocdef(hp).struct) and not tprocdef(hp).forwarddef then
  1586. continue;
  1587. { and the body is available already (which is implicitely the
  1588. case if the generic routine is part of another unit) }
  1589. if ((hmodule=current_module) or (hmodule.state=ms_compile)) and
  1590. { may not be assigned in case it's a synthetic procdef that
  1591. still needs to be generated }
  1592. assigned(tprocdef(hp).genericdef) and
  1593. tprocdef(tprocdef(hp).genericdef).forwarddef then
  1594. begin
  1595. result:=false;
  1596. continue;
  1597. end;
  1598. process_procdef(tprocdef(hp),hmodule);
  1599. end
  1600. else
  1601. if hp.typ in [objectdef,recorddef] then
  1602. { generate code for subtypes as well }
  1603. result:=process_abstractrecorddef(tabstractrecorddef(hp)) and result;
  1604. end;
  1605. end;
  1606. procedure generate_specialization_procs;
  1607. var
  1608. i : longint;
  1609. list,
  1610. readdlist : tfpobjectlist;
  1611. def : tstoreddef;
  1612. state : tspecializationstate;
  1613. hmodule : tmodule;
  1614. begin
  1615. { first copy all entries and then work with that list to ensure that
  1616. we don't get an infinite recursion }
  1617. list:=tfpobjectlist.create(false);
  1618. readdlist:=tfpobjectlist.create(false);
  1619. for i:=0 to current_module.pendingspecializations.Count-1 do
  1620. list.add(current_module.pendingspecializations.Items[i]);
  1621. current_module.pendingspecializations.clear;
  1622. for i:=0 to list.count-1 do
  1623. begin
  1624. def:=tstoreddef(list[i]);
  1625. if not tstoreddef(def).is_specialization then
  1626. continue;
  1627. case def.typ of
  1628. procdef:
  1629. begin
  1630. { the use of forwarddef should not backfire as the
  1631. specialization always belongs to the current module }
  1632. if not tprocdef(def).forwarddef then
  1633. continue;
  1634. if not assigned(def.genericdef) then
  1635. internalerror(2015061903);
  1636. hmodule:=find_module_from_symtable(def.genericdef.owner);
  1637. if hmodule=nil then
  1638. internalerror(2015061904);
  1639. { we need to check for a forward declaration only if the
  1640. generic was declared in the same unit (otherwise there
  1641. should be one) }
  1642. if ((hmodule=current_module) or (hmodule.state=ms_compile)) and tprocdef(def.genericdef).forwarddef then
  1643. begin
  1644. readdlist.add(def);
  1645. continue;
  1646. end;
  1647. specialization_init(tstoreddef(def).genericdef,state);
  1648. process_procdef(tprocdef(def),hmodule);
  1649. specialization_done(state);
  1650. end;
  1651. recorddef,
  1652. objectdef:
  1653. begin
  1654. specialization_init(tstoreddef(def).genericdef,state);
  1655. if not process_abstractrecorddef(tabstractrecorddef(def)) then
  1656. readdlist.add(def);
  1657. specialization_done(state);
  1658. end;
  1659. else
  1660. ;
  1661. end;
  1662. end;
  1663. { add those defs back to the pending list for which we don't yet have
  1664. all method bodies }
  1665. for i:=0 to readdlist.count-1 do
  1666. current_module.pendingspecializations.add(tstoreddef(readdlist[i]).typename,readdlist[i]);
  1667. readdlist.free;
  1668. list.free;
  1669. end;
  1670. procedure maybe_add_pending_specialization(def:tdef);
  1671. var
  1672. hmodule : tmodule;
  1673. st : tsymtable;
  1674. begin
  1675. if parse_generic then
  1676. exit;
  1677. st:=def.owner;
  1678. while st.symtabletype in [localsymtable] do
  1679. st:=st.defowner.owner;
  1680. hmodule:=find_module_from_symtable(st);
  1681. if tstoreddef(def).is_specialization and (hmodule=current_module) then
  1682. current_module.pendingspecializations.add(def.typename,def);
  1683. end;
  1684. end.