pgenutil.pas 94 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258
  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;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);inline;
  31. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _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;const symname:string;symtable:tsymtable):tdef;inline;
  34. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
  35. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;const _prettyname:ansistring):tdef;
  36. function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean;
  37. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  38. function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  39. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist;isfwd:boolean);
  40. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  41. function generate_generic_name(const name:tidstring;const specializename:ansistring;const 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 generate_specializations_for_forwarddef(def:tdef);
  48. procedure maybe_add_pending_specialization(def:tdef);
  49. function determine_generic_def(const name:tidstring):tstoreddef;
  50. procedure specialization_init(genericdef:tdef;var state:tspecializationstate);
  51. procedure specialization_done(var state:tspecializationstate);
  52. implementation
  53. uses
  54. { common }
  55. cutils,fpchash,
  56. { global }
  57. globals,tokens,verbose,finput,constexp,
  58. { symtable }
  59. symconst,symsym,symtable,defcmp,defutil,procinfo,
  60. { modules }
  61. fmodule,
  62. node,nobj,ncon,
  63. { parser }
  64. scanner,
  65. pbase,pexpr,pdecsub,ptype,psub,pparautl,pdecl;
  66. type
  67. tdeftypeset = set of tdeftyp;
  68. const
  69. tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,floatdef,setdef,pointerdef,enumdef];
  70. tgeneric_param_nodes : tnodetypeset = [typen,ordconstn,stringconstn,realconstn,setconstn,niln];
  71. function get_generic_param_def(sym:tsym):tdef;
  72. begin
  73. if sym.typ=constsym then
  74. result:=tconstsym(sym).constdef
  75. else
  76. result:=ttypesym(sym).typedef;
  77. end;
  78. function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean;
  79. begin
  80. if (value.valueord<param2.low) or (value.valueord>param2.high) then
  81. result:=false
  82. else
  83. result:=true;
  84. end;
  85. function compare_generic_params(param1,param2:tdef;constparamsym:tconstsym):boolean;
  86. begin
  87. if (param1.typ=orddef) and (param2.typ=orddef) then
  88. begin
  89. if is_boolean(param2) then
  90. result:=is_boolean(param1)
  91. else if is_char(param2) then
  92. result:=is_char(param1)
  93. else if compare_orddef_by_range(torddef(param1),torddef(param2),constparamsym.value) then
  94. result:=true
  95. else
  96. result:=false;
  97. end
  98. { arraydef is string constant so it's compatible with stringdef }
  99. else if (param1.typ=arraydef) and (param2.typ=stringdef) then
  100. result:=true
  101. { integer ords are compatible with float }
  102. else if (param1.typ=orddef) and is_integer(param1) and (param2.typ=floatdef) then
  103. result:=true
  104. { chars are compatible with stringdef }
  105. else if (param1.typ=orddef) and is_char(param1) and (param2.typ=stringdef) then
  106. result:=true
  107. { undefined def is compatible with all types }
  108. else if param2.typ=undefineddef then
  109. result:=true
  110. { sets require stricter checks }
  111. else if is_set(param2) then
  112. result:=equal_defs(param1,param2)
  113. else
  114. result:=param1.typ=param2.typ;
  115. end;
  116. function create_generic_constsym(fromdef:tdef;node:tnode;out prettyname:string):tconstsym;
  117. const
  118. undefinedname = 'undefined';
  119. var
  120. sym : tconstsym;
  121. setdef : tsetdef;
  122. enumsym : tsym;
  123. enumname : string;
  124. sp : pchar;
  125. ps : ^tconstset;
  126. pd : ^bestreal;
  127. i : integer;
  128. begin
  129. if node=nil then
  130. internalerror(2020011401);
  131. case node.nodetype of
  132. ordconstn:
  133. begin
  134. sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef);
  135. prettyname:=tostr(tordconstnode(node).value.svalue);
  136. end;
  137. stringconstn:
  138. begin
  139. getmem(sp,tstringconstnode(node).len+1);
  140. move(tstringconstnode(node).value_str^,sp^,tstringconstnode(node).len+1);
  141. sym:=cconstsym.create_string(undefinedname,conststring,sp,tstringconstnode(node).len,fromdef);
  142. prettyname:=''''+tstringconstnode(node).value_str+'''';
  143. end;
  144. realconstn:
  145. begin
  146. new(pd);
  147. pd^:=trealconstnode(node).value_real;
  148. sym:=cconstsym.create_ptr(undefinedname,constreal,pd,fromdef);
  149. prettyname:=realtostr(trealconstnode(node).value_real);
  150. end;
  151. setconstn:
  152. begin
  153. new(ps);
  154. ps^:=tsetconstnode(node).value_set^;
  155. sym:=cconstsym.create_ptr(undefinedname,constset,ps,fromdef);
  156. setdef:=tsetdef(tsetconstnode(node).resultdef);
  157. prettyname:='[';
  158. for i := setdef.setbase to setdef.setmax do
  159. if i in tsetconstnode(node).value_set^ then
  160. begin
  161. if setdef.elementdef.typ=enumdef then
  162. enumsym:=tenumdef(setdef.elementdef).int2enumsym(i)
  163. else
  164. enumsym:=nil;
  165. if assigned(enumsym) then
  166. enumname:=enumsym.realname
  167. else if setdef.elementdef.typ=orddef then
  168. begin
  169. if torddef(setdef.elementdef).ordtype=uchar then
  170. enumname:=chr(i)
  171. else
  172. enumname:=tostr(i);
  173. end
  174. else
  175. enumname:=tostr(i);
  176. if length(prettyname) > 1 then
  177. prettyname:=prettyname+','+enumname
  178. else
  179. prettyname:=prettyname+enumname;
  180. end;
  181. prettyname:=prettyname+']';
  182. end;
  183. niln:
  184. begin
  185. { only "nil" is available for pointer constants }
  186. sym:=cconstsym.create_ord(undefinedname,constnil,0,fromdef);
  187. prettyname:='nil';
  188. end;
  189. else
  190. internalerror(2019021601);
  191. end;
  192. { the sym needs an owner for later checks so use the typeparam owner }
  193. sym.owner:=fromdef.owner;
  194. include(sym.symoptions,sp_generic_const);
  195. result:=sym;
  196. end;
  197. procedure maybe_add_waiting_unit(tt:tdef);
  198. var
  199. hmodule : tmodule;
  200. begin
  201. if not assigned(tt) or
  202. not (df_generic in tt.defoptions) then
  203. exit;
  204. hmodule:=find_module_from_symtable(tt.owner);
  205. if not assigned(hmodule) then
  206. internalerror(2012092401);
  207. if hmodule=current_module then
  208. exit;
  209. if hmodule.state<>ms_compiled then
  210. begin
  211. {$ifdef DEBUG_UNITWAITING}
  212. Writeln('Unit ', current_module.modulename^,
  213. ' waiting for ', hmodule.modulename^);
  214. {$endif DEBUG_UNITWAITING}
  215. if current_module.waitingforunit.indexof(hmodule)<0 then
  216. current_module.waitingforunit.add(hmodule);
  217. if hmodule.waitingunits.indexof(current_module)<0 then
  218. hmodule.waitingunits.add(current_module);
  219. end;
  220. end;
  221. procedure add_forward_generic_def(def:tdef;context:tspecializationcontext);
  222. var
  223. list : tfpobjectlist;
  224. fwdcontext : tspecializationcontext;
  225. begin
  226. if not is_implicit_pointer_object_type(def) then
  227. internalerror(2020070301);
  228. if not (oo_is_forward in tobjectdef(def).objectoptions) then
  229. internalerror(2020070302);
  230. if not assigned(tobjectdef(def).genericdef) then
  231. internalerror(2020070303);
  232. list:=tfpobjectlist(current_module.forwardgenericdefs.find(tobjectdef(def).genericdef.fulltypename));
  233. if not assigned(list) then
  234. begin
  235. list:=tfpobjectlist.create(true);
  236. current_module.forwardgenericdefs.add(tobjectdef(def).genericdef.fulltypename,list);
  237. end;
  238. fwdcontext:=context.getcopy;
  239. fwdcontext.forwarddef:=def;
  240. list.add(fwdcontext);
  241. end;
  242. function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean;
  243. var
  244. i,j,
  245. intfcount : longint;
  246. formaldef,
  247. paradef : tstoreddef;
  248. genparadef : tdef;
  249. objdef,
  250. paraobjdef,
  251. formalobjdef : tobjectdef;
  252. intffound : boolean;
  253. filepos : tfileposinfo;
  254. is_const : boolean;
  255. begin
  256. { check whether the given specialization parameters fit to the eventual
  257. constraints of the generic }
  258. if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then
  259. internalerror(2012101001);
  260. if genericdef.genericparas.count<>paramlist.count then
  261. internalerror(2012101002);
  262. if paramlist.count<>poslist.count then
  263. internalerror(2012120801);
  264. result:=true;
  265. for i:=0 to genericdef.genericparas.count-1 do
  266. begin
  267. filepos:=pfileposinfo(poslist[i])^;
  268. paradef:=tstoreddef(get_generic_param_def(tsym(paramlist[i])));
  269. is_const:=tsym(paramlist[i]).typ=constsym;
  270. genparadef:=genericdef.get_generic_param_def(i);
  271. { validate const params }
  272. if not genericdef.is_generic_param_const(i) and is_const then
  273. begin
  274. MessagePos(filepos,type_e_mismatch);
  275. exit(false);
  276. end
  277. else if genericdef.is_generic_param_const(i) then
  278. begin
  279. { param type mismatch (type <> const) }
  280. if genericdef.is_generic_param_const(i)<>is_const then
  281. begin
  282. MessagePos(filepos,type_e_mismatch);
  283. exit(false);
  284. end;
  285. { type constrained param doesn't match type }
  286. if not compare_generic_params(paradef,genericdef.get_generic_param_def(i),tconstsym(paramlist[i])) then
  287. begin
  288. MessagePos2(filepos,type_e_incompatible_types,FullTypeName(paradef,genparadef),FullTypeName(genparadef,paradef));
  289. exit(false);
  290. end;
  291. end;
  292. { test constraints for non-const params }
  293. if not genericdef.is_generic_param_const(i) then
  294. begin
  295. formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef);
  296. if formaldef.typ=undefineddef then
  297. { the parameter is of unspecified type, so no need to check }
  298. continue;
  299. if not (df_genconstraint in formaldef.defoptions) or
  300. not assigned(formaldef.genconstraintdata) then
  301. internalerror(2013021602);
  302. { undefineddef is compatible with anything }
  303. if formaldef.typ=undefineddef then
  304. continue;
  305. if paradef.typ<>formaldef.typ then
  306. begin
  307. case formaldef.typ of
  308. recorddef:
  309. { delphi has own fantasy about record constraint
  310. (almost non-nullable/non-nilable value type) }
  311. if m_delphi in current_settings.modeswitches then
  312. case paradef.typ of
  313. floatdef,enumdef,orddef:
  314. continue;
  315. objectdef:
  316. if tobjectdef(paradef).objecttype=odt_object then
  317. continue
  318. else
  319. MessagePos(filepos,type_e_record_type_expected);
  320. else
  321. MessagePos(filepos,type_e_record_type_expected);
  322. end
  323. else
  324. MessagePos(filepos,type_e_record_type_expected);
  325. objectdef:
  326. case tobjectdef(formaldef).objecttype of
  327. odt_class,
  328. odt_javaclass:
  329. MessagePos1(filepos,type_e_class_type_expected,paradef.typename);
  330. odt_interfacecom,
  331. odt_interfacecorba,
  332. odt_dispinterface,
  333. odt_interfacejava:
  334. MessagePos1(filepos,type_e_interface_type_expected,paradef.typename);
  335. else
  336. internalerror(2012101003);
  337. end;
  338. errordef:
  339. { ignore }
  340. ;
  341. else
  342. internalerror(2012101004);
  343. end;
  344. result:=false;
  345. end
  346. else
  347. begin
  348. { the paradef types are the same, so do special checks for the
  349. cases in which they are needed }
  350. if formaldef.typ=objectdef then
  351. begin
  352. paraobjdef:=tobjectdef(paradef);
  353. formalobjdef:=tobjectdef(formaldef);
  354. if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then
  355. internalerror(2012101102);
  356. if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then
  357. begin
  358. { this is either a concerete interface or class type (the
  359. latter without specific implemented interfaces) }
  360. case paraobjdef.objecttype of
  361. odt_interfacecom,
  362. odt_interfacecorba,
  363. odt_interfacejava,
  364. odt_dispinterface:
  365. begin
  366. if (oo_is_forward in paraobjdef.objectoptions) and
  367. (paraobjdef.objecttype=formalobjdef.objecttype) and
  368. (df_genconstraint in formalobjdef.defoptions) and
  369. (
  370. (formalobjdef.objecttype=odt_interfacecom) and
  371. (formalobjdef.childof=interface_iunknown)
  372. )
  373. or
  374. (
  375. (formalobjdef.objecttype=odt_interfacecorba) and
  376. (formalobjdef.childof=nil)
  377. ) then
  378. continue;
  379. if not def_is_related(paraobjdef,formalobjdef.childof) then
  380. begin
  381. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  382. result:=false;
  383. end;
  384. end;
  385. odt_class,
  386. odt_javaclass:
  387. begin
  388. objdef:=paraobjdef;
  389. intffound:=false;
  390. while assigned(objdef) do
  391. begin
  392. for j:=0 to objdef.implementedinterfaces.count-1 do
  393. if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then
  394. begin
  395. intffound:=true;
  396. break;
  397. end;
  398. if intffound then
  399. break;
  400. objdef:=objdef.childof;
  401. end;
  402. result:=intffound;
  403. if not result then
  404. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename);
  405. end;
  406. else
  407. begin
  408. MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename);
  409. result:=false;
  410. end;
  411. end;
  412. end
  413. else
  414. begin
  415. { this is either a "class" or a concrete instance with
  416. or without implemented interfaces }
  417. if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then
  418. begin
  419. MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename);
  420. result:=false;
  421. continue;
  422. end;
  423. { for forward declared classes we allow pure TObject/class declarations }
  424. if (oo_is_forward in paraobjdef.objectoptions) and
  425. (df_genconstraint in formaldef.defoptions) then
  426. begin
  427. if (formalobjdef.childof=class_tobject) and
  428. not formalobjdef.implements_any_interfaces then
  429. continue;
  430. end;
  431. if assigned(formalobjdef.childof) and
  432. not def_is_related(paradef,formalobjdef.childof) then
  433. begin
  434. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  435. result:=false;
  436. end;
  437. intfcount:=0;
  438. for j:=0 to formalobjdef.implementedinterfaces.count-1 do
  439. begin
  440. objdef:=paraobjdef;
  441. while assigned(objdef) do
  442. begin
  443. intffound:=assigned(
  444. find_implemented_interface(objdef,
  445. timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef
  446. )
  447. );
  448. if intffound then
  449. break;
  450. objdef:=objdef.childof;
  451. end;
  452. if intffound then
  453. inc(intfcount)
  454. else
  455. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename);
  456. end;
  457. if intfcount<>formalobjdef.implementedinterfaces.count then
  458. result:=false;
  459. end;
  460. end;
  461. end;
  462. end;
  463. end;
  464. end;
  465. function parse_generic_specialization_types_internal(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
  466. var
  467. old_block_type : tblock_type;
  468. first : boolean;
  469. typeparam : tnode;
  470. parampos : pfileposinfo;
  471. tmpparampos : tfileposinfo;
  472. namepart : string;
  473. prettynamepart : ansistring;
  474. module : tmodule;
  475. constprettyname : string;
  476. validparam : boolean;
  477. begin
  478. result:=true;
  479. prettyname:='';
  480. prettynamepart:='';
  481. if paramlist=nil then
  482. internalerror(2012061401);
  483. { set the block type to type, so that the parsed type are returned as
  484. ttypenode (e.g. classes are in non type-compatible blocks returned as
  485. tloadvmtaddrnode) }
  486. old_block_type:=block_type;
  487. { if parsedtype is set, then the first type identifer was already parsed
  488. (happens in inline specializations) and thus we only need to parse
  489. the remaining types and do as if the first one was already given }
  490. first:=not assigned(parsedtype);
  491. if assigned(parsedtype) then
  492. begin
  493. paramlist.Add(parsedtype.typesym);
  494. module:=find_module_from_symtable(parsedtype.owner);
  495. if not assigned(module) then
  496. internalerror(2016112801);
  497. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+parsedtype.unique_id_str;
  498. specializename:='$'+namepart;
  499. prettyname:=parsedtype.fullownerhierarchyname(true)+parsedtype.typesym.prettyname;
  500. if assigned(poslist) then
  501. begin
  502. New(parampos);
  503. parampos^:=parsedpos;
  504. poslist.add(parampos);
  505. end;
  506. end
  507. else
  508. specializename:='$';
  509. while not (token in [_GT,_RSHARPBRACKET]) do
  510. begin
  511. { "first" is set to false at the end of the loop! }
  512. if not first then
  513. consume(_COMMA);
  514. block_type:=bt_type;
  515. tmpparampos:=current_filepos;
  516. typeparam:=factor(false,[ef_accept_equal]);
  517. { determine if the typeparam node is a valid type or const }
  518. validparam:=typeparam.nodetype in tgeneric_param_nodes;
  519. if validparam then
  520. begin
  521. if tstoreddef(typeparam.resultdef).is_generic and
  522. (
  523. not parse_generic or
  524. not defs_belong_to_same_generic(typeparam.resultdef,current_genericdef)
  525. ) then
  526. Message(parser_e_no_generics_as_params);
  527. if assigned(poslist) then
  528. begin
  529. New(parampos);
  530. parampos^:=tmpparampos;
  531. poslist.add(parampos);
  532. end;
  533. if typeparam.resultdef.typ<>errordef then
  534. begin
  535. if (typeparam.nodetype=typen) and not assigned(typeparam.resultdef.typesym) then
  536. message(type_e_generics_cannot_reference_itself)
  537. else if (typeparam.resultdef.typ<>errordef) then
  538. begin
  539. { all non-type nodes are considered const }
  540. if typeparam.nodetype<>typen then
  541. paramlist.Add(create_generic_constsym(typeparam.resultdef,typeparam,constprettyname))
  542. else
  543. begin
  544. constprettyname:='';
  545. paramlist.Add(typeparam.resultdef.typesym);
  546. end;
  547. module:=find_module_from_symtable(typeparam.resultdef.owner);
  548. if not assigned(module) then
  549. internalerror(2016112802);
  550. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+typeparam.resultdef.unique_id_str;
  551. if constprettyname<>'' then
  552. namepart:=namepart+'$$'+constprettyname;
  553. { we use the full name of the type to uniquely identify it }
  554. if typeparam.nodetype=typen then
  555. begin
  556. if (symtablestack.top.symtabletype=parasymtable) and
  557. (symtablestack.top.defowner.typ=procdef) and
  558. (typeparam.resultdef.owner=symtablestack.top) then
  559. begin
  560. { special handling for specializations inside generic function declarations }
  561. prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname;
  562. end
  563. else
  564. begin
  565. prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true);
  566. end;
  567. end;
  568. specializename:=specializename+namepart;
  569. if not first then
  570. prettyname:=prettyname+',';
  571. if constprettyname<>'' then
  572. prettyname:=prettyname+constprettyname
  573. else
  574. prettyname:=prettyname+prettynamepart+typeparam.resultdef.typesym.prettyname;
  575. end;
  576. end
  577. else
  578. begin
  579. result:=false;
  580. end;
  581. end
  582. else
  583. begin
  584. Message(type_e_type_id_expected);
  585. result:=false;
  586. end;
  587. typeparam.free;
  588. first:=false;
  589. end;
  590. block_type:=old_block_type;
  591. end;
  592. function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  593. var
  594. dummypos : tfileposinfo;
  595. begin
  596. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  597. result:=parse_generic_specialization_types_internal(paramlist,poslist,prettyname,specializename,nil,dummypos);
  598. end;
  599. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string);
  600. var
  601. dummypos : tfileposinfo;
  602. begin
  603. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  604. generate_specialization(tt,parse_class_parent,_prettyname,nil,'',dummypos);
  605. end;
  606. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;
  607. var
  608. dummypos : tfileposinfo;
  609. {$push}
  610. {$warn 5036 off}
  611. begin
  612. result:=generate_specialization_phase1(context,genericdef,nil,'',nil,dummypos);
  613. end;
  614. {$pop}
  615. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;const symname:string;symtable:tsymtable):tdef;
  616. var
  617. dummypos : tfileposinfo;
  618. {$push}
  619. {$warn 5036 off}
  620. begin
  621. result:=generate_specialization_phase1(context,genericdef,nil,symname,symtable,dummypos);
  622. end;
  623. {$pop}
  624. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
  625. var
  626. found,
  627. err : boolean;
  628. i,
  629. gencount : longint;
  630. countstr,genname,ugenname : string;
  631. tmpstack : tfpobjectlist;
  632. symowner : tsymtable;
  633. begin
  634. context:=nil;
  635. result:=nil;
  636. { either symname must be given or genericdef needs to be valid }
  637. if (symname='') and
  638. (not assigned(genericdef) or
  639. (
  640. (genericdef.typ<>procdef) and
  641. (
  642. not assigned(genericdef.typesym) or
  643. (genericdef.typesym.typ<>typesym)
  644. ) and
  645. (
  646. (genericdef.typ<>objectdef) or
  647. not (oo_is_forward in tobjectdef(genericdef).objectoptions)
  648. )
  649. ) or
  650. (
  651. (genericdef.typ=procdef) and
  652. (
  653. not assigned(tprocdef(genericdef).procsym) or
  654. (tprocdef(genericdef).procsym.typ<>procsym)
  655. )
  656. )
  657. ) then
  658. begin
  659. internalerror(2019112401);
  660. end;
  661. if not assigned(parsedtype) and not try_to_consume(_LT) then
  662. begin
  663. consume(_LSHARPBRACKET);
  664. { handle "<>" }
  665. if (token=_GT) or (token=_RSHARPBRACKET) then
  666. begin
  667. Message(type_e_type_id_expected);
  668. if not try_to_consume(_GT) then
  669. try_to_consume(_RSHARPBRACKET);
  670. result:=generrordef;
  671. exit;
  672. end;
  673. end;
  674. context:=tspecializationcontext.create;
  675. { Parse type parameters }
  676. err:=not parse_generic_specialization_types_internal(context.paramlist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos);
  677. if err then
  678. begin
  679. if not try_to_consume(_GT) then
  680. try_to_consume(_RSHARPBRACKET);
  681. context.free;
  682. context:=nil;
  683. result:=generrordef;
  684. exit;
  685. end;
  686. { use the name of the symbol as procvars return a user friendly version
  687. of the name }
  688. if symname='' then
  689. begin
  690. if genericdef.typ=procdef then
  691. genname:=tprocdef(genericdef).procsym.realname
  692. else if assigned(genericdef.typesym) then
  693. genname:=ttypesym(genericdef.typesym).realname
  694. else if (genericdef.typ=objectdef) and (oo_is_forward in tobjectdef(genericdef).objectoptions) then
  695. genname:=tobjectdef(genericdef).objrealname^
  696. else
  697. internalerror(2020071201);
  698. end
  699. else
  700. genname:=symname;
  701. { in case of non-Delphi mode the type name could already be a generic
  702. def (but maybe the wrong one) }
  703. if assigned(genericdef) and
  704. ([df_generic,df_specialization]*genericdef.defoptions<>[]) then
  705. begin
  706. { remove the type count suffix from the generic's name }
  707. for i:=Length(genname) downto 1 do
  708. if genname[i]='$' then
  709. begin
  710. genname:=copy(genname,1,i-1);
  711. break;
  712. end;
  713. { in case of a specialization we've only reached the specialization
  714. checksum yet }
  715. if df_specialization in genericdef.defoptions then
  716. for i:=length(genname) downto 1 do
  717. if genname[i]='$' then
  718. begin
  719. genname:=copy(genname,1,i-1);
  720. break;
  721. end;
  722. end
  723. else
  724. begin
  725. split_generic_name(genname,ugenname,gencount);
  726. if genname<>ugenname then
  727. genname:=ugenname;
  728. end;
  729. { search a generic with the given count of params }
  730. countstr:='';
  731. str(context.paramlist.Count,countstr);
  732. genname:=genname+'$'+countstr;
  733. ugenname:=upper(genname);
  734. context.genname:=genname;
  735. if assigned(genericdef) then
  736. symowner:=genericdef.owner
  737. else
  738. symowner:=symtable;
  739. if assigned(symowner) and (symowner.symtabletype in [objectsymtable,recordsymtable]) then
  740. begin
  741. if symowner.symtabletype = objectsymtable then
  742. found:=searchsym_in_class(tobjectdef(symowner.defowner),tobjectdef(symowner.defowner),ugenname,context.sym,context.symtable,[])
  743. else
  744. found:=searchsym_in_record(tabstractrecorddef(symowner.defowner),ugenname,context.sym,context.symtable);
  745. if not found then
  746. found:=searchsym(ugenname,context.sym,context.symtable);
  747. end
  748. else
  749. found:=searchsym(ugenname,context.sym,context.symtable);
  750. if found and (context.sym.typ=absolutevarsym) and
  751. (vo_is_funcret in tabstractvarsym(context.sym).varoptions) then
  752. begin
  753. { we found the function result alias of a generic function; go up the
  754. symbol stack *before* this alias was inserted, so that we can
  755. (hopefully) find the correct generic symbol }
  756. tmpstack:=tfpobjectlist.create(false);
  757. while assigned(symtablestack.top) do
  758. begin
  759. tmpstack.Add(symtablestack.top);
  760. symtablestack.pop(symtablestack.top);
  761. if tmpstack.Last=context.symtable then
  762. break;
  763. end;
  764. if not assigned(symtablestack.top) then
  765. internalerror(2019123001);
  766. found:=searchsym(ugenname,context.sym,context.symtable);
  767. for i:=tmpstack.count-1 downto 0 do
  768. symtablestack.push(tsymtable(tmpstack[i]));
  769. tmpstack.free;
  770. end;
  771. if not found or not (context.sym.typ in [typesym,procsym]) then
  772. begin
  773. identifier_not_found(genname);
  774. if not try_to_consume(_GT) then
  775. try_to_consume(_RSHARPBRACKET);
  776. context.free;
  777. context:=nil;
  778. result:=generrordef;
  779. exit;
  780. end;
  781. { we've found the correct def }
  782. if context.sym.typ=typesym then
  783. result:=tstoreddef(ttypesym(context.sym).typedef)
  784. else
  785. begin
  786. if tprocsym(context.sym).procdeflist.count=0 then
  787. internalerror(2015061203);
  788. result:=tstoreddef(tprocsym(context.sym).procdefList[0]);
  789. end;
  790. if not try_to_consume(_GT) then
  791. consume(_RSHARPBRACKET);
  792. end;
  793. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;const _prettyname:ansistring):tdef;
  794. procedure unset_forwarddef(def: tdef);
  795. var
  796. st : TSymtable;
  797. i : longint;
  798. begin
  799. { since commit 48986 deflist might have NIL entries }
  800. if not assigned(def) then
  801. exit;
  802. case def.typ of
  803. procdef:
  804. tprocdef(def).forwarddef:=false;
  805. objectdef,
  806. recorddef:
  807. begin
  808. st:=def.getsymtable(gs_record);
  809. for i:=0 to st.deflist.count-1 do
  810. unset_forwarddef(tdef(st.deflist[i]));
  811. end;
  812. else
  813. ;
  814. end;
  815. end;
  816. procedure retrieve_genericdef_or_procsym(sym:tsym;out gendef:tdef;out psym:tsym);
  817. var
  818. i : longint;
  819. begin
  820. gendef:=nil;
  821. psym:=nil;
  822. case sym.typ of
  823. typesym:
  824. begin
  825. gendef:=ttypesym(sym).typedef
  826. end;
  827. procsym:
  828. begin
  829. for i:=0 to tprocsym(sym).procdeflist.count-1 do
  830. if tstoreddef(tprocsym(sym).procdeflist[i]).genericdef=genericdef then
  831. begin
  832. gendef:=tdef(tprocsym(sym).procdeflist[i]);
  833. break;
  834. end;
  835. psym:=sym;
  836. end
  837. else
  838. internalerror(200710171);
  839. end;
  840. end;
  841. var
  842. finalspecializename,
  843. ufinalspecializename : tidstring;
  844. prettyname : ansistring;
  845. generictypelist : tfphashobjectlist;
  846. srsymtable,
  847. specializest : tsymtable;
  848. hashedid : thashedidstring;
  849. tempst : tglobalsymtable;
  850. tsrsym : ttypesym;
  851. psym,
  852. srsym : tsym;
  853. paramdef1,
  854. paramdef2,
  855. def : tdef;
  856. old_block_type : tblock_type;
  857. state : tspecializationstate;
  858. old_current_structdef : tabstractrecorddef;
  859. old_current_specializedef,
  860. old_current_genericdef : tstoreddef;
  861. old_current_procinfo : tprocinfo;
  862. old_module_procinfo : tobject;
  863. hmodule : tmodule;
  864. oldcurrent_filepos : tfileposinfo;
  865. recordbuf : tdynamicarray;
  866. hadtypetoken : boolean;
  867. i,
  868. replaydepth : longint;
  869. item : tobject;
  870. allequal,
  871. hintsprocessed : boolean;
  872. pd : tprocdef;
  873. pdflags : tpdflags;
  874. begin
  875. if not assigned(context) then
  876. internalerror(2015052203);
  877. result:=nil;
  878. pd:=nil;
  879. if not check_generic_constraints(genericdef,context.paramlist,context.poslist) then
  880. begin
  881. { the parameters didn't fit the constraints, so don't continue with the
  882. specialization }
  883. result:=generrordef;
  884. exit;
  885. end;
  886. { build the new type's name }
  887. finalspecializename:=generate_generic_name(context.genname,context.specializename,genericdef.ownerhierarchyname);
  888. ufinalspecializename:=upper(finalspecializename);
  889. if genericdef.typ=procdef then
  890. prettyname:=tprocdef(genericdef).procsym.prettyname
  891. else
  892. prettyname:=genericdef.typesym.prettyname;
  893. prettyname:=prettyname+'<'+context.prettyname+'>';
  894. generictypelist:=tfphashobjectlist.create(false);
  895. { build the list containing the types for the generic params }
  896. if not assigned(genericdef.genericparas) then
  897. internalerror(2013092601);
  898. if context.paramlist.count<>genericdef.genericparas.count then
  899. internalerror(2013092603);
  900. for i:=0 to genericdef.genericparas.Count-1 do
  901. begin
  902. srsym:=tsym(genericdef.genericparas[i]);
  903. if not (sp_generic_para in srsym.symoptions) then
  904. internalerror(2013092602);
  905. generictypelist.add(srsym.realname,context.paramlist[i]);
  906. end;
  907. { Special case if we are referencing the current defined object }
  908. if assigned(current_structdef) and
  909. (current_structdef.objname^=ufinalspecializename) then
  910. result:=current_structdef;
  911. { Can we reuse an already specialized type? }
  912. { for this first check whether we are currently specializing a nested
  913. type of the current (main) specialization (this is necessary, because
  914. during that time the symbol of the main specialization will still
  915. contain a reference to an errordef) }
  916. if not assigned(result) and assigned(current_specializedef) then
  917. begin
  918. def:=current_specializedef;
  919. repeat
  920. if def.typ in [objectdef,recorddef] then
  921. if tabstractrecorddef(def).objname^=ufinalspecializename then begin
  922. result:=def;
  923. break;
  924. end;
  925. if assigned(def.owner) then
  926. def:=tstoreddef(def.owner.defowner)
  927. else
  928. { this can happen when specializing a generic function }
  929. def:=nil;
  930. until not assigned(def) or not (df_specialization in def.defoptions);
  931. end;
  932. { if the genericdef is the def we are currently parsing (or one of its parents) then we can
  933. not use it for specializing as the tokenbuffer is not yet set (and we aren't done with
  934. parsing anyway), so for now we treat those still as generic defs without doing a partial
  935. specialization }
  936. if not assigned(result) then
  937. begin
  938. def:=current_genericdef;
  939. while assigned(def) and (def.typ in [recorddef,objectdef]) do
  940. begin
  941. if (df_generic in def.defoptions) and (def=genericdef) then
  942. begin
  943. result:=def;
  944. break;
  945. end;
  946. { the following happens when a routine with its parent struct
  947. as parameter is specialized as a parameter or result of a
  948. generic function }
  949. if (df_specialization in def.defoptions) and (tstoreddef(def).genericdef=genericdef) then
  950. begin
  951. if tstoreddef(def).genericparas.count=generictypelist.count then
  952. begin
  953. allequal:=true;
  954. for i:=0 to generictypelist.count-1 do
  955. begin
  956. if tsym(generictypelist[i]).typ<>tsym(tstoreddef(def).genericparas[i]).typ then
  957. begin
  958. allequal:=false;
  959. break;
  960. end;
  961. if tsym(generictypelist[i]).typ=constsym then
  962. paramdef1:=tconstsym(generictypelist[i]).constdef
  963. else
  964. paramdef1:=ttypesym(generictypelist[i]).typedef;
  965. if tsym(tstoreddef(def).genericparas[i]).typ=constsym then
  966. paramdef2:=tconstsym(tstoreddef(def).genericparas[i]).constdef
  967. else
  968. paramdef2:=ttypesym(tstoreddef(def).genericparas[i]).typedef;
  969. if not equal_defs(paramdef1,paramdef2) then
  970. begin
  971. allequal:=false;
  972. break;
  973. end;
  974. if (tsym(generictypelist[i]).typ=constsym) and
  975. (
  976. (tconstsym(generictypelist[i]).consttyp<>tconstsym(tstoreddef(def).genericparas[i]).consttyp) or
  977. not same_constvalue(tconstsym(generictypelist[i]).consttyp,tconstsym(generictypelist[i]).value,tconstsym(tstoreddef(def).genericparas[i]).value)
  978. ) then
  979. begin
  980. allequal:=false;
  981. break;
  982. end;
  983. end;
  984. if allequal then
  985. begin
  986. result:=def;
  987. break;
  988. end;
  989. end;
  990. end;
  991. def:=tstoreddef(def.owner.defowner);
  992. end;
  993. end;
  994. { decide in which symtable to put the specialization }
  995. if assigned(context.forwarddef) then
  996. begin
  997. specializest:=context.forwarddef.owner;
  998. end
  999. else if parse_generic and not assigned(result) then
  1000. begin
  1001. srsymtable:=symtablestack.top;
  1002. if (srsymtable.symtabletype in [localsymtable,parasymtable]) and tstoreddef(srsymtable.defowner).is_specialization then
  1003. { if we are currently specializing a routine we need to specialize into
  1004. the routine's local- or parasymtable so that they are correctly
  1005. registered should the specialization be finalized }
  1006. specializest:=srsymtable
  1007. else if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
  1008. { if we are parsing the definition of a method we specialize into
  1009. the local symtable of it }
  1010. specializest:=current_procinfo.procdef.getsymtable(gs_local)
  1011. else
  1012. begin
  1013. if not assigned(current_genericdef) then
  1014. internalerror(2014050901);
  1015. { we specialize the partial specialization into the symtable of the currently parsed
  1016. generic }
  1017. case current_genericdef.typ of
  1018. procvardef:
  1019. specializest:=current_genericdef.getsymtable(gs_para);
  1020. procdef:
  1021. specializest:=current_genericdef.getsymtable(gs_local);
  1022. objectdef,
  1023. recorddef:
  1024. specializest:=current_genericdef.getsymtable(gs_record);
  1025. arraydef:
  1026. specializest:=tarraydef(current_genericdef).symtable;
  1027. else
  1028. internalerror(2014050902);
  1029. end;
  1030. end;
  1031. end
  1032. else
  1033. if current_module.is_unit and current_module.in_interface then
  1034. specializest:=current_module.globalsymtable
  1035. else
  1036. specializest:=current_module.localsymtable;
  1037. if not assigned(specializest) then
  1038. internalerror(2014050910);
  1039. { now check whether there is a specialization somewhere else }
  1040. psym:=nil;
  1041. if not assigned(result) then
  1042. begin
  1043. hashedid.id:=ufinalspecializename;
  1044. if (specializest.symtabletype=objectsymtable) and not assigned(context.forwarddef) then
  1045. begin
  1046. { search also in parent classes }
  1047. if not assigned(current_genericdef) or (current_genericdef.typ<>objectdef) then
  1048. internalerror(2016112901);
  1049. if not searchsym_in_class(tobjectdef(current_genericdef),tobjectdef(current_genericdef),ufinalspecializename,srsym,srsymtable,[]) then
  1050. srsym:=nil;
  1051. end
  1052. else
  1053. srsym:=tsym(specializest.findwithhash(hashedid));
  1054. if assigned(context.forwarddef) then
  1055. begin
  1056. { just do a few sanity checks }
  1057. if not assigned(srsym) or not (srsym.typ=typesym) then
  1058. internalerror(2020070306);
  1059. if ttypesym(srsym).typedef<>context.forwarddef then
  1060. internalerror(2020070307);
  1061. end
  1062. else if assigned(srsym) then
  1063. begin
  1064. retrieve_genericdef_or_procsym(srsym,result,psym);
  1065. end
  1066. else
  1067. { the generic could have been specialized in the globalsymtable
  1068. already, so search there as well }
  1069. if (specializest<>current_module.globalsymtable) and assigned(current_module.globalsymtable) then
  1070. begin
  1071. srsym:=tsym(current_module.globalsymtable.findwithhash(hashedid));
  1072. if assigned(srsym) then
  1073. begin
  1074. retrieve_genericdef_or_procsym(srsym,result,psym);
  1075. end;
  1076. end;
  1077. end;
  1078. if not assigned(result) then
  1079. begin
  1080. specialization_init(genericdef,state);
  1081. { push a temporary global symtable so that the specialization is
  1082. added to the correct symtable; this symtable does not contain
  1083. any other symbols, so that the type resolution can not be
  1084. influenced by symbols in the current unit }
  1085. tempst:=tspecializesymtable.create(current_module.modulename^,current_module.moduleid);
  1086. symtablestack.push(tempst);
  1087. { Reparse the original type definition }
  1088. begin
  1089. old_current_specializedef:=nil;
  1090. old_current_genericdef:=nil;
  1091. old_current_structdef:=nil;
  1092. old_current_procinfo:=current_procinfo;
  1093. old_module_procinfo:=current_module.procinfo;
  1094. current_procinfo:=nil;
  1095. current_module.procinfo:=nil;
  1096. if parse_class_parent then
  1097. begin
  1098. old_current_structdef:=current_structdef;
  1099. old_current_genericdef:=current_genericdef;
  1100. old_current_specializedef:=current_specializedef;
  1101. if genericdef.owner.symtabletype in [recordsymtable,objectsymtable] then
  1102. current_structdef:=tabstractrecorddef(genericdef.owner.defowner)
  1103. else
  1104. current_structdef:=nil;
  1105. current_genericdef:=nil;
  1106. current_specializedef:=nil;
  1107. end;
  1108. maybe_add_waiting_unit(genericdef);
  1109. { First a new sym so we can reuse this specialization and
  1110. references to this specialization can be handled }
  1111. if genericdef.typ=procdef then
  1112. if assigned(psym) then
  1113. srsym:=psym
  1114. else
  1115. srsym:=cprocsym.create(finalspecializename)
  1116. else
  1117. srsym:=ctypesym.create(finalspecializename,generrordef);
  1118. { insert the symbol only if we don't know already that we have
  1119. a procsym to add it to and we aren't dealing with a forwarddef }
  1120. if not assigned(psym) and not assigned(context.forwarddef) then
  1121. specializest.insert(srsym);
  1122. { specializations are declarations as such it is the wisest to
  1123. declare set the blocktype to "type"; otherwise we'll
  1124. experience unexpected side effects like the addition of
  1125. classrefdefs if we have a generic that's derived from another
  1126. generic }
  1127. old_block_type:=block_type;
  1128. block_type:=bt_type;
  1129. if (
  1130. (genericdef.typ=procdef) and
  1131. not assigned(tprocdef(genericdef).genericdecltokenbuf)
  1132. ) or (
  1133. (genericdef.typ<>procdef) and
  1134. not assigned(genericdef.generictokenbuf)
  1135. ) then
  1136. internalerror(200511171);
  1137. hmodule:=find_module_from_symtable(genericdef.owner);
  1138. if hmodule=nil then
  1139. internalerror(2012051202);
  1140. oldcurrent_filepos:=current_filepos;
  1141. { use the index the module got from the current compilation process }
  1142. current_filepos.moduleindex:=hmodule.unit_index;
  1143. current_tokenpos:=current_filepos;
  1144. if parse_generic then
  1145. begin
  1146. recordbuf:=current_scanner.recordtokenbuf;
  1147. current_scanner.recordtokenbuf:=nil;
  1148. end
  1149. else
  1150. recordbuf:=nil;
  1151. replaydepth:=current_scanner.replay_stack_depth;
  1152. if genericdef.typ=procdef then
  1153. begin
  1154. current_scanner.startreplaytokens(tprocdef(genericdef).genericdecltokenbuf,hmodule.change_endian);
  1155. parse_proc_head(tprocdef(genericdef).struct,tprocdef(genericdef).proctypeoption,false,genericdef,generictypelist,pd);
  1156. if assigned(pd) then
  1157. begin
  1158. if assigned(psym) then
  1159. pd.procsym:=psym
  1160. else
  1161. pd.procsym:=srsym;
  1162. parse_proc_dec_finish(pd,po_classmethod in tprocdef(genericdef).procoptions,tprocdef(genericdef).struct);
  1163. end;
  1164. result:=pd;
  1165. end
  1166. else
  1167. begin
  1168. current_scanner.startreplaytokens(genericdef.generictokenbuf,hmodule.change_endian);
  1169. if assigned(context.forwarddef) then
  1170. begin
  1171. tsrsym:=nil;
  1172. result:=parse_forward_declaration(context.forwarddef.typesym,ufinalspecializename,finalspecializename,genericdef,generictypelist,tsrsym);
  1173. srsym:=tsrsym;
  1174. end
  1175. else
  1176. begin
  1177. hadtypetoken:=false;
  1178. read_named_type(result,srsym,genericdef,generictypelist,false,hadtypetoken);
  1179. ttypesym(srsym).typedef:=result;
  1180. result.typesym:=srsym;
  1181. end;
  1182. if _prettyname<>'' then
  1183. ttypesym(result.typesym).fprettyname:=_prettyname
  1184. else
  1185. ttypesym(result.typesym).fprettyname:=prettyname;
  1186. end;
  1187. current_filepos:=oldcurrent_filepos;
  1188. { Note regarding hint directives:
  1189. There is no need to remove the flags for them from the
  1190. specialized generic symbol, because hint directives that
  1191. follow the specialization are handled by the code in
  1192. pdecl.types_dec and added to the type symbol.
  1193. E.g.: TFoo = TBar<Blubb> deprecated;
  1194. Here the symbol TBar$1$Blubb will contain the
  1195. "sp_hint_deprecated" flag while the TFoo symbol won't.}
  1196. case result.typ of
  1197. { Build VMT indexes for classes and read hint directives }
  1198. objectdef:
  1199. begin
  1200. if replaydepth>current_scanner.replay_stack_depth then
  1201. begin
  1202. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  1203. if replaydepth>current_scanner.replay_stack_depth then
  1204. consume(_SEMICOLON);
  1205. end;
  1206. if oo_is_forward in tobjectdef(result).objectoptions then
  1207. add_forward_generic_def(result,context)
  1208. else
  1209. build_vmt(tobjectdef(result));
  1210. end;
  1211. { handle params, calling convention, etc }
  1212. procvardef:
  1213. begin
  1214. hintsprocessed:=false;
  1215. if replaydepth>current_scanner.replay_stack_depth then
  1216. begin
  1217. if not check_proc_directive(true) then
  1218. begin
  1219. hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  1220. if replaydepth>current_scanner.replay_stack_depth then
  1221. consume(_SEMICOLON);
  1222. end
  1223. else
  1224. hintsprocessed:=true;
  1225. end;
  1226. if replaydepth>current_scanner.replay_stack_depth then
  1227. parse_var_proc_directives(ttypesym(srsym));
  1228. handle_calling_convention(tprocvardef(result),hcc_default_actions_intf);
  1229. if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then
  1230. begin
  1231. try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  1232. if replaydepth>current_scanner.replay_stack_depth then
  1233. consume(_SEMICOLON);
  1234. end;
  1235. end;
  1236. procdef:
  1237. begin
  1238. pdflags:=[];
  1239. if genericdef.owner.symtabletype=objectsymtable then
  1240. include(pdflags,pd_object)
  1241. else if genericdef.owner.symtabletype=recordsymtable then
  1242. include(pdflags,pd_record);
  1243. parse_proc_directives(pd,pdflags);
  1244. while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
  1245. consume(_SEMICOLON);
  1246. if parse_generic then
  1247. handle_calling_convention(tprocdef(result),hcc_default_actions_intf)
  1248. else
  1249. handle_calling_convention(tprocdef(result),hcc_default_actions_impl);
  1250. pdflags:=pdflags+[pd_body,pd_implemen];
  1251. proc_add_definition(tprocdef(result));
  1252. { for partial specializations we implicitely declare the routine as
  1253. having its implementation although we'll not specialize it in reality }
  1254. if parse_generic then
  1255. unset_forwarddef(result);
  1256. end;
  1257. else
  1258. { parse hint directives for records and arrays }
  1259. if replaydepth>current_scanner.replay_stack_depth then begin
  1260. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  1261. if replaydepth>current_scanner.replay_stack_depth then
  1262. consume(_SEMICOLON);
  1263. end;
  1264. end;
  1265. { Consume the remainder of the buffer }
  1266. while current_scanner.replay_stack_depth>replaydepth do
  1267. consume(token);
  1268. if assigned(recordbuf) then
  1269. begin
  1270. if assigned(current_scanner.recordtokenbuf) then
  1271. internalerror(2014050909);
  1272. current_scanner.recordtokenbuf:=recordbuf;
  1273. end;
  1274. block_type:=old_block_type;
  1275. current_procinfo:=old_current_procinfo;
  1276. current_module.procinfo:=old_module_procinfo;
  1277. if parse_class_parent then
  1278. begin
  1279. current_structdef:=old_current_structdef;
  1280. current_genericdef:=old_current_genericdef;
  1281. current_specializedef:=old_current_specializedef;
  1282. end;
  1283. end;
  1284. { extract all created symbols and defs from the temporary symtable
  1285. and add them to the specializest }
  1286. for i:=tempst.SymList.Count-1 downto 0 do
  1287. begin
  1288. item:=tempst.SymList.Items[i];
  1289. { using changeowner the symbol is automatically added to the
  1290. new symtable }
  1291. tsym(item).ChangeOwner(specializest);
  1292. end;
  1293. for i:=tempst.DefList.Count-1 downto 0 do
  1294. begin
  1295. item:=tempst.DefList.Items[i];
  1296. { using changeowner the def is automatically added to the new
  1297. symtable }
  1298. tdef(item).ChangeOwner(specializest);
  1299. { for partial specializations we implicitely declare any methods as having their
  1300. implementations although we'll not specialize them in reality }
  1301. if parse_generic then
  1302. unset_forwarddef(tdef(item));
  1303. end;
  1304. { if a generic was declared during the specialization we need to
  1305. flag the specialize symtable accordingly }
  1306. if sto_has_generic in tempst.tableoptions then
  1307. specializest.includeoption(sto_has_generic);
  1308. tempst.free;
  1309. specialization_done(state);
  1310. { procdefs are only added once we know which overload we use }
  1311. if not parse_generic and (result.typ<>procdef) then
  1312. current_module.pendingspecializations.add(result.typename,result);
  1313. end;
  1314. generictypelist.free;
  1315. if assigned(genericdef) then
  1316. begin
  1317. { check the hints of the found generic symbol }
  1318. if genericdef.typ=procdef then
  1319. srsym:=tprocdef(genericdef).procsym
  1320. else
  1321. srsym:=genericdef.typesym;
  1322. check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
  1323. end;
  1324. end;
  1325. procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);
  1326. var
  1327. context : tspecializationcontext;
  1328. genericdef : tstoreddef;
  1329. begin
  1330. genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,nil,parsedpos));
  1331. if genericdef<>generrordef then
  1332. genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname));
  1333. tt:=genericdef;
  1334. if assigned(context) then
  1335. context.free;
  1336. end;
  1337. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  1338. var
  1339. generictype : tstoredsym;
  1340. i,firstidx,const_list_index : longint;
  1341. srsymtable : tsymtable;
  1342. basedef,def : tdef;
  1343. defname : tidstring;
  1344. allowconst,
  1345. allowconstructor,
  1346. is_const,
  1347. doconsume : boolean;
  1348. constraintdata : tgenericconstraintdata;
  1349. old_block_type : tblock_type;
  1350. fileinfo : tfileposinfo;
  1351. begin
  1352. result:=tfphashobjectlist.create(false);
  1353. firstidx:=0;
  1354. const_list_index:=0;
  1355. old_block_type:=block_type;
  1356. block_type:=bt_type;
  1357. allowconst:=true;
  1358. is_const:=false;
  1359. repeat
  1360. if allowconst and try_to_consume(_CONST) then
  1361. begin
  1362. allowconst:=false;
  1363. is_const:=true;
  1364. const_list_index:=result.count;
  1365. end;
  1366. if token=_ID then
  1367. begin
  1368. if is_const then
  1369. generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype)
  1370. else
  1371. generictype:=ctypesym.create(orgpattern,cundefinedtype);
  1372. { type parameters need to be added as strict private }
  1373. generictype.visibility:=vis_strictprivate;
  1374. include(generictype.symoptions,sp_generic_para);
  1375. result.add(orgpattern,generictype);
  1376. end;
  1377. consume(_ID);
  1378. fileinfo:=current_tokenpos;
  1379. { const restriction }
  1380. if is_const and try_to_consume(_COLON) then
  1381. begin
  1382. def:=nil;
  1383. { parse the type and assign the const type to generictype }
  1384. single_type(def,[]);
  1385. for i:=const_list_index to result.count-1 do
  1386. begin
  1387. { finalize constant information once type is known }
  1388. if assigned(def) and (def.typ in tgeneric_param_const_types) then
  1389. begin
  1390. case def.typ of
  1391. orddef,
  1392. enumdef:
  1393. tconstsym(result[i]).consttyp:=constord;
  1394. stringdef:
  1395. tconstsym(result[i]).consttyp:=conststring;
  1396. floatdef:
  1397. tconstsym(result[i]).consttyp:=constreal;
  1398. setdef:
  1399. tconstsym(result[i]).consttyp:=constset;
  1400. { pointer always refers to nil with constants }
  1401. pointerdef:
  1402. tconstsym(result[i]).consttyp:=constnil;
  1403. else
  1404. internalerror(2020011402);
  1405. end;
  1406. tconstsym(result[i]).constdef:=def;
  1407. end
  1408. else
  1409. Message1(type_e_generic_const_type_not_allowed,def.fulltypename);
  1410. end;
  1411. { after type restriction const list terminates }
  1412. is_const:=false;
  1413. end
  1414. { type restriction }
  1415. else if try_to_consume(_COLON) then
  1416. begin
  1417. if not allowconstraints then
  1418. Message(parser_e_generic_constraints_not_allowed_here);
  1419. { construct a name which can be used for a type specification }
  1420. constraintdata:=tgenericconstraintdata.create;
  1421. constraintdata.fileinfo:=fileinfo;
  1422. defname:='';
  1423. str(current_module.deflist.count,defname);
  1424. defname:='$gendef'+defname;
  1425. allowconstructor:=m_delphi in current_settings.modeswitches;
  1426. basedef:=generrordef;
  1427. repeat
  1428. doconsume:=true;
  1429. case token of
  1430. _CONSTRUCTOR:
  1431. begin
  1432. if not allowconstructor or (gcf_constructor in constraintdata.flags) then
  1433. Message(parser_e_illegal_expression);
  1434. include(constraintdata.flags,gcf_constructor);
  1435. allowconstructor:=false;
  1436. end;
  1437. _CLASS:
  1438. begin
  1439. if gcf_class in constraintdata.flags then
  1440. Message(parser_e_illegal_expression);
  1441. if basedef=generrordef then
  1442. include(constraintdata.flags,gcf_class)
  1443. else
  1444. Message(parser_e_illegal_expression);
  1445. end;
  1446. _RECORD:
  1447. begin
  1448. if ([gcf_constructor,gcf_class]*constraintdata.flags<>[])
  1449. or (constraintdata.interfaces.count>0) then
  1450. Message(parser_e_illegal_expression)
  1451. else
  1452. begin
  1453. srsymtable:=trecordsymtable.create(defname,0,1);
  1454. basedef:=crecorddef.create(defname,srsymtable);
  1455. include(constraintdata.flags,gcf_record);
  1456. allowconstructor:=false;
  1457. end;
  1458. end;
  1459. else
  1460. begin
  1461. { after single_type "token" is the trailing ",", ";" or
  1462. ">"! }
  1463. doconsume:=false;
  1464. { def is already set to a class or record }
  1465. if gcf_record in constraintdata.flags then
  1466. Message(parser_e_illegal_expression);
  1467. single_type(def, [stoAllowSpecialization]);
  1468. { only types that are inheritable are allowed }
  1469. if (def.typ<>objectdef) or
  1470. not (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_javaclass]) then
  1471. Message1(type_e_class_or_interface_type_expected,def.typename)
  1472. else
  1473. case tobjectdef(def).objecttype of
  1474. odt_class,
  1475. odt_javaclass:
  1476. begin
  1477. if gcf_class in constraintdata.flags then
  1478. { "class" + concrete class is not allowed }
  1479. Message(parser_e_illegal_expression)
  1480. else
  1481. { do we already have a concrete class? }
  1482. if basedef<>generrordef then
  1483. Message(parser_e_illegal_expression)
  1484. else
  1485. basedef:=def;
  1486. end;
  1487. odt_interfacecom,
  1488. odt_interfacecorba,
  1489. odt_interfacejava,
  1490. odt_dispinterface:
  1491. constraintdata.interfaces.add(def);
  1492. else
  1493. ;
  1494. end;
  1495. end;
  1496. end;
  1497. if doconsume then
  1498. consume(token);
  1499. until not try_to_consume(_COMMA);
  1500. if ([gcf_class,gcf_constructor]*constraintdata.flags<>[]) or
  1501. (constraintdata.interfaces.count>1) or
  1502. (
  1503. (basedef.typ=objectdef) and
  1504. (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class])
  1505. ) then
  1506. begin
  1507. if basedef.typ=errordef then
  1508. { don't pass an errordef as a parent to a tobjectdef }
  1509. basedef:=class_tobject
  1510. else
  1511. if (basedef.typ<>objectdef) or
  1512. not (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class]) then
  1513. internalerror(2012101101);
  1514. basedef:=cobjectdef.create(tobjectdef(basedef).objecttype,defname,tobjectdef(basedef),false);
  1515. for i:=0 to constraintdata.interfaces.count-1 do
  1516. tobjectdef(basedef).implementedinterfaces.add(
  1517. timplementedinterface.create(tobjectdef(constraintdata.interfaces[i])));
  1518. end
  1519. else
  1520. if constraintdata.interfaces.count=1 then
  1521. begin
  1522. if basedef.typ<>errordef then
  1523. internalerror(2013021601);
  1524. def:=tdef(constraintdata.interfaces[0]);
  1525. basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false);
  1526. constraintdata.interfaces.delete(0);
  1527. end;
  1528. if basedef.typ<>errordef then
  1529. with tstoreddef(basedef) do
  1530. begin
  1531. genconstraintdata:=tgenericconstraintdata.create;
  1532. genconstraintdata.flags:=constraintdata.flags;
  1533. genconstraintdata.interfaces.assign(constraintdata.interfaces);
  1534. genconstraintdata.fileinfo:=constraintdata.fileinfo;
  1535. include(defoptions,df_genconstraint);
  1536. end;
  1537. for i:=firstidx to result.count-1 do
  1538. ttypesym(result[i]).typedef:=basedef;
  1539. { we need a typesym in case we do a Delphi-mode inline
  1540. specialization with this parameter; so just use the first sym }
  1541. if not assigned(basedef.typesym) then
  1542. basedef.typesym:=ttypesym(result[firstidx]);
  1543. firstidx:=result.count;
  1544. constraintdata.free;
  1545. end
  1546. else
  1547. begin
  1548. if token=_SEMICOLON then
  1549. begin
  1550. { two different typeless parameters are considered as incompatible }
  1551. for i:=firstidx to result.count-1 do
  1552. if tsym(result[i]).typ<>constsym then
  1553. begin
  1554. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  1555. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  1556. end;
  1557. { a semicolon terminates a type parameter group }
  1558. firstidx:=result.count;
  1559. end;
  1560. end;
  1561. if token=_SEMICOLON then
  1562. begin
  1563. is_const:=false;
  1564. allowconst:=true;
  1565. end;
  1566. until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON));
  1567. { if the constant parameter is not terminated then the type restriction was
  1568. not specified and we need to give an error }
  1569. if is_const then
  1570. consume(_COLON);
  1571. { two different typeless parameters are considered as incompatible }
  1572. for i:=firstidx to result.count-1 do
  1573. if tsym(result[i]).typ<>constsym then
  1574. begin
  1575. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  1576. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  1577. end;
  1578. block_type:=old_block_type;
  1579. end;
  1580. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist;isfwd:boolean);
  1581. var
  1582. i : longint;
  1583. generictype,
  1584. fwdparam : tstoredsym;
  1585. generictypedef : tdef;
  1586. sym : tsym;
  1587. st : tsymtable;
  1588. fwdok : boolean;
  1589. conv : tconverttype;
  1590. op : tprocdef;
  1591. begin
  1592. def.genericdef:=genericdef;
  1593. if not assigned(genericlist) then
  1594. exit;
  1595. if assigned(genericdef) then
  1596. include(def.defoptions,df_specialization)
  1597. else
  1598. if genericlist.count>0 then
  1599. include(def.defoptions,df_generic);
  1600. case def.typ of
  1601. recorddef,objectdef: st:=tabstractrecorddef(def).symtable;
  1602. arraydef: st:=tarraydef(def).symtable;
  1603. procvardef,procdef: st:=tabstractprocdef(def).parast;
  1604. else
  1605. internalerror(201101020);
  1606. end;
  1607. { if we have a forwarddef we check whether the generic parameters are
  1608. equal and otherwise ignore the list }
  1609. if isfwd then
  1610. begin
  1611. fwdok:=true;
  1612. if (genericlist.count>0) and
  1613. (
  1614. not assigned(def.genericparas)
  1615. or (def.genericparas.count<>genericlist.count)
  1616. ) then
  1617. fwdok:=false
  1618. else
  1619. begin
  1620. for i:=0 to genericlist.count-1 do
  1621. begin
  1622. if def.genericparas.nameofindex(i)<>genericlist.nameofindex(i) then
  1623. begin
  1624. fwdok:=false;
  1625. break;
  1626. end;
  1627. generictype:=tstoredsym(genericlist[i]);
  1628. fwdparam:=tstoredsym(def.genericparas[i]);
  1629. op:=nil;
  1630. conv:=tc_equal;
  1631. if generictype.typ<>fwdparam.typ then
  1632. fwdok:=false
  1633. else if (generictype.typ=typesym) then
  1634. begin
  1635. if compare_defs_ext(ttypesym(generictype).typedef,ttypesym(fwdparam).typedef,nothingn,conv,op,[cdo_strict_genconstraint_check])<te_exact then
  1636. fwdok:=false;
  1637. end
  1638. else if (generictype.typ=constsym) then
  1639. begin
  1640. if (tconstsym(generictype).consttyp<>tconstsym(fwdparam).consttyp) or
  1641. (compare_defs_ext(tconstsym(generictype).constdef,tconstsym(fwdparam).constdef,nothingn,conv,op,[cdo_strict_genconstraint_check])<te_exact) then
  1642. fwdok:=false;
  1643. end
  1644. else
  1645. internalerror(2020070101);
  1646. if not fwdok then
  1647. break;
  1648. end;
  1649. end;
  1650. if not fwdok then
  1651. Message(parser_e_forward_mismatch);
  1652. exit;
  1653. end;
  1654. if (genericlist.count>0) and not assigned(def.genericparas) then
  1655. def.genericparas:=tfphashobjectlist.create(false);
  1656. for i:=0 to genericlist.count-1 do
  1657. begin
  1658. generictype:=tstoredsym(genericlist[i]);
  1659. if assigned(generictype.owner) then
  1660. begin
  1661. if generictype.typ=typesym then
  1662. sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef)
  1663. else if generictype.typ=constsym then
  1664. { generictype is a constsym that was created in create_generic_constsym
  1665. during phase 1 so we pass this directly without copying }
  1666. begin
  1667. sym:=generictype;
  1668. { the sym name is still undefined so we set it to match
  1669. the generic param name so it's accessible }
  1670. sym.realname:=genericlist.nameofindex(i);
  1671. include(sym.symoptions,sp_generic_const);
  1672. end
  1673. else
  1674. internalerror(2019021602);
  1675. { type parameters need to be added as strict private }
  1676. sym.visibility:=vis_strictprivate;
  1677. st.insert(sym);
  1678. include(sym.symoptions,sp_generic_para);
  1679. end
  1680. else
  1681. begin
  1682. if generictype.typ=typesym then
  1683. begin
  1684. generictypedef:=ttypesym(generictype).typedef;
  1685. if (generictypedef.typ=undefineddef) and (generictypedef<>cundefinedtype) then
  1686. begin
  1687. { the generic parameters were parsed before the genericdef existed thus the
  1688. undefineddefs were added as part of the parent symtable }
  1689. if assigned(generictypedef.owner) then
  1690. generictypedef.owner.DefList.Extract(generictypedef);
  1691. generictypedef.changeowner(st);
  1692. end;
  1693. end;
  1694. st.insert(generictype);
  1695. include(generictype.symoptions,sp_generic_para);
  1696. end;
  1697. def.genericparas.add(genericlist.nameofindex(i),generictype);
  1698. end;
  1699. end;
  1700. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  1701. var
  1702. gensym : ttypesym;
  1703. begin
  1704. { for generics in non-Delphi modes we insert a private type symbol
  1705. that has the same base name as the currently parsed generic and
  1706. that references this defs }
  1707. if not (m_delphi in current_settings.modeswitches) and
  1708. (
  1709. (
  1710. parse_generic and
  1711. assigned(genericlist) and
  1712. (genericlist.count>0)
  1713. ) or
  1714. (
  1715. assigned(current_specializedef) and
  1716. assigned(current_structdef.genericdef) and
  1717. (current_structdef.genericdef.typ in [objectdef,recorddef]) and
  1718. (pos('$',name)>0)
  1719. )
  1720. ) then
  1721. begin
  1722. { we need to pass nil as def here, because the constructor wants
  1723. to set the typesym of the def which is not what we want }
  1724. gensym:=ctypesym.create(copy(name,1,pos('$',name)-1),nil);
  1725. gensym.typedef:=current_structdef;
  1726. include(gensym.symoptions,sp_internal);
  1727. { the symbol should be only visible to the generic class
  1728. itself }
  1729. gensym.visibility:=vis_strictprivate;
  1730. symtablestack.top.insert(gensym);
  1731. end;
  1732. end;
  1733. function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:string):tidstring;
  1734. var
  1735. crc : cardinal;
  1736. begin
  1737. if specializename='' then
  1738. internalerror(2012061901);
  1739. { build the new type's name }
  1740. crc:=UpdateCrc32(0,specializename[1],length(specializename));
  1741. result:=name+'$crc'+hexstr(crc,8);
  1742. if owner_hierarchy<>'' then
  1743. begin
  1744. crc:=UpdateCrc32(0,owner_hierarchy[1],length(owner_hierarchy));
  1745. result:=result+'$crc'+hexstr(crc,8);
  1746. end;
  1747. end;
  1748. procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
  1749. var
  1750. i,code : longint;
  1751. countstr : string;
  1752. begin
  1753. for i:=length(name) downto 1 do
  1754. if name[i]='$' then
  1755. begin
  1756. nongeneric:=copy(name,1,i-1);
  1757. countstr:=copy(name,i+1,length(name)-i);
  1758. val(countstr,count,code);
  1759. if code<>0 then
  1760. break;
  1761. exit;
  1762. end;
  1763. nongeneric:=name;
  1764. count:=0;
  1765. end;
  1766. procedure add_generic_dummysym(sym:tsym);
  1767. var
  1768. list: TFPObjectList;
  1769. srsym : tsym;
  1770. srsymtable : tsymtable;
  1771. entry : tgenericdummyentry;
  1772. begin
  1773. if sp_generic_dummy in sym.symoptions then
  1774. begin
  1775. { did we already search for a generic with that name? }
  1776. list:=tfpobjectlist(current_module.genericdummysyms.find(sym.name));
  1777. if not assigned(list) then
  1778. begin
  1779. list:=tfpobjectlist.create(true);
  1780. current_module.genericdummysyms.add(sym.name,list);
  1781. end;
  1782. { is the dummy sym still "dummy"? }
  1783. if (sym.typ=typesym) and
  1784. (
  1785. { dummy sym defined in mode Delphi }
  1786. (ttypesym(sym).typedef.typ=undefineddef) or
  1787. { dummy sym defined in non-Delphi mode }
  1788. (tstoreddef(ttypesym(sym).typedef).is_generic)
  1789. ) then
  1790. begin
  1791. { do we have a non-generic type of the same name
  1792. available? }
  1793. if not searchsym_with_flags(sym.name,srsym,srsymtable,[ssf_no_addsymref]) then
  1794. srsym:=nil;
  1795. end
  1796. else if sym.typ=procsym then
  1797. srsym:=sym
  1798. else
  1799. { dummy symbol is already not so dummy anymore }
  1800. srsym:=nil;
  1801. if assigned(srsym) then
  1802. begin
  1803. entry:=tgenericdummyentry.create;
  1804. entry.resolvedsym:=srsym;
  1805. entry.dummysym:=sym;
  1806. list.add(entry);
  1807. end;
  1808. end;
  1809. end;
  1810. function resolve_generic_dummysym(const name:tidstring):tsym;
  1811. var
  1812. list : tfpobjectlist;
  1813. begin
  1814. list:=tfpobjectlist(current_module.genericdummysyms.find(name));
  1815. if assigned(list) and (list.count>0) then
  1816. result:=tgenericdummyentry(list.last).resolvedsym
  1817. else
  1818. result:=nil;
  1819. end;
  1820. function could_be_generic(const name:tidstring):boolean;
  1821. begin
  1822. result:=(name<>'') and
  1823. (current_module.genericdummysyms.findindexof(name)>=0);
  1824. end;
  1825. procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
  1826. var
  1827. pu : tused_unit;
  1828. hmodule : tmodule;
  1829. unitsyms : TFPHashObjectList;
  1830. sym : tsym;
  1831. i : Integer;
  1832. begin
  1833. if not assigned(genericdef) then
  1834. internalerror(200705151);
  1835. { Setup symtablestack at definition time
  1836. to get types right, however this is not perfect, we should probably record
  1837. the resolved symbols }
  1838. state.oldsymtablestack:=symtablestack;
  1839. state.oldextendeddefs:=current_module.extendeddefs;
  1840. state.oldgenericdummysyms:=current_module.genericdummysyms;
  1841. current_module.extendeddefs:=TFPHashObjectList.create(true);
  1842. current_module.genericdummysyms:=tfphashobjectlist.create(true);
  1843. symtablestack:=tdefawaresymtablestack.create;
  1844. hmodule:=find_module_from_symtable(genericdef.owner);
  1845. if hmodule=nil then
  1846. internalerror(200705152);
  1847. { collect all unit syms in the generic's unit as we need to establish
  1848. their unitsym.module link again so that unit identifiers can be used }
  1849. unitsyms:=tfphashobjectlist.create(false);
  1850. if (hmodule<>current_module) and assigned(hmodule.globalsymtable) then
  1851. for i:=0 to hmodule.globalsymtable.symlist.count-1 do
  1852. begin
  1853. sym:=tsym(hmodule.globalsymtable.symlist[i]);
  1854. if sym.typ=unitsym then
  1855. unitsyms.add(upper(sym.realname),sym);
  1856. end;
  1857. { add all units if we are specializing inside the current unit (as the
  1858. generic could have been declared in the implementation part), but load
  1859. only interface units, if we are in a different unit as then the generic
  1860. needs to be in the interface section }
  1861. pu:=tused_unit(hmodule.used_units.first);
  1862. while assigned(pu) do
  1863. begin
  1864. if not assigned(pu.u.globalsymtable) then
  1865. { in certain circular, but valid unit constellations it can happen
  1866. that we specialize a generic in a different unit that was used
  1867. in the implementation section of the generic's unit and were the
  1868. interface is still being parsed and thus the localsymtable is in
  1869. reality the global symtable }
  1870. if pu.u.in_interface then
  1871. symtablestack.push(pu.u.localsymtable)
  1872. else
  1873. internalerror(200705153)
  1874. else
  1875. symtablestack.push(pu.u.globalsymtable);
  1876. sym:=tsym(unitsyms.find(pu.u.modulename^));
  1877. if assigned(sym) and not assigned(tunitsym(sym).module) then
  1878. tunitsym(sym).module:=pu.u;
  1879. pu:=tused_unit(pu.next);
  1880. end;
  1881. unitsyms.free;
  1882. if assigned(hmodule.globalsymtable) then
  1883. symtablestack.push(hmodule.globalsymtable);
  1884. { push the localsymtable if needed }
  1885. if ((hmodule<>current_module) or not current_module.in_interface)
  1886. and assigned(hmodule.localsymtable) then
  1887. symtablestack.push(hmodule.localsymtable);
  1888. end;
  1889. procedure specialization_done(var state: tspecializationstate);
  1890. begin
  1891. { Restore symtablestack }
  1892. current_module.extendeddefs.free;
  1893. current_module.extendeddefs:=state.oldextendeddefs;
  1894. current_module.genericdummysyms.free;
  1895. current_module.genericdummysyms:=state.oldgenericdummysyms;
  1896. symtablestack.free;
  1897. symtablestack:=state.oldsymtablestack;
  1898. { clear the state record to be on the safe side }
  1899. fillchar(state, sizeof(state), 0);
  1900. end;
  1901. {****************************************************************************
  1902. SPECIALIZATION BODY GENERATION
  1903. ****************************************************************************}
  1904. procedure process_procdef(def:tprocdef;hmodule:tmodule);
  1905. var
  1906. oldcurrent_filepos : tfileposinfo;
  1907. begin
  1908. if assigned(def.genericdef) and
  1909. (def.genericdef.typ=procdef) and
  1910. assigned(tprocdef(def.genericdef).generictokenbuf) then
  1911. begin
  1912. if not assigned(tprocdef(def.genericdef).generictokenbuf) then
  1913. internalerror(2015061902);
  1914. oldcurrent_filepos:=current_filepos;
  1915. current_filepos:=tprocdef(def.genericdef).fileinfo;
  1916. { use the index the module got from the current compilation process }
  1917. current_filepos.moduleindex:=hmodule.unit_index;
  1918. current_tokenpos:=current_filepos;
  1919. current_scanner.startreplaytokens(tprocdef(def.genericdef).generictokenbuf,hmodule.change_endian);
  1920. read_proc_body(def);
  1921. current_filepos:=oldcurrent_filepos;
  1922. end
  1923. { synthetic routines will be implemented afterwards }
  1924. else if def.synthetickind=tsk_none then
  1925. MessagePos1(def.fileinfo,sym_e_forward_not_resolved,def.fullprocname(false));
  1926. end;
  1927. function process_abstractrecorddef(def:tabstractrecorddef):boolean;
  1928. var
  1929. i : longint;
  1930. hp : tdef;
  1931. hmodule : tmodule;
  1932. begin
  1933. result:=true;
  1934. hmodule:=find_module_from_symtable(def.genericdef.owner);
  1935. if hmodule=nil then
  1936. internalerror(201202041);
  1937. for i:=0 to def.symtable.DefList.Count-1 do
  1938. begin
  1939. hp:=tdef(def.symtable.DefList[i]);
  1940. if hp.typ=procdef then
  1941. begin
  1942. { only generate the code if we need a body }
  1943. if assigned(tprocdef(hp).struct) and not tprocdef(hp).forwarddef then
  1944. continue;
  1945. { and the body is available already (which is implicitely the
  1946. case if the generic routine is part of another unit) }
  1947. if ((hmodule=current_module) or (hmodule.state=ms_compile)) and
  1948. { may not be assigned in case it's a synthetic procdef that
  1949. still needs to be generated }
  1950. assigned(tprocdef(hp).genericdef) and
  1951. tprocdef(tprocdef(hp).genericdef).forwarddef then
  1952. begin
  1953. result:=false;
  1954. continue;
  1955. end;
  1956. process_procdef(tprocdef(hp),hmodule);
  1957. end
  1958. else
  1959. if hp.typ in [objectdef,recorddef] then
  1960. { generate code for subtypes as well }
  1961. result:=process_abstractrecorddef(tabstractrecorddef(hp)) and result;
  1962. end;
  1963. end;
  1964. procedure generate_specialization_procs;
  1965. var
  1966. i : longint;
  1967. list,
  1968. readdlist : tfpobjectlist;
  1969. def : tstoreddef;
  1970. state : tspecializationstate;
  1971. hmodule : tmodule;
  1972. begin
  1973. { first copy all entries and then work with that list to ensure that
  1974. we don't get an infinite recursion }
  1975. list:=tfpobjectlist.create(false);
  1976. readdlist:=tfpobjectlist.create(false);
  1977. for i:=0 to current_module.pendingspecializations.Count-1 do
  1978. list.add(current_module.pendingspecializations.Items[i]);
  1979. current_module.pendingspecializations.clear;
  1980. for i:=0 to list.count-1 do
  1981. begin
  1982. def:=tstoreddef(list[i]);
  1983. if not tstoreddef(def).is_specialization then
  1984. continue;
  1985. case def.typ of
  1986. procdef:
  1987. begin
  1988. { the use of forwarddef should not backfire as the
  1989. specialization always belongs to the current module }
  1990. if not tprocdef(def).forwarddef then
  1991. continue;
  1992. if not assigned(def.genericdef) then
  1993. internalerror(2015061903);
  1994. hmodule:=find_module_from_symtable(def.genericdef.owner);
  1995. if hmodule=nil then
  1996. internalerror(2015061904);
  1997. { we need to check for a forward declaration only if the
  1998. generic was declared in the same unit (otherwise there
  1999. should be one) }
  2000. if ((hmodule=current_module) or (hmodule.state=ms_compile)) and tprocdef(def.genericdef).forwarddef then
  2001. begin
  2002. readdlist.add(def);
  2003. continue;
  2004. end;
  2005. specialization_init(tstoreddef(def).genericdef,state);
  2006. process_procdef(tprocdef(def),hmodule);
  2007. specialization_done(state);
  2008. end;
  2009. recorddef,
  2010. objectdef:
  2011. begin
  2012. specialization_init(tstoreddef(def).genericdef,state);
  2013. if not process_abstractrecorddef(tabstractrecorddef(def)) then
  2014. readdlist.add(def);
  2015. specialization_done(state);
  2016. end;
  2017. else
  2018. ;
  2019. end;
  2020. end;
  2021. { add those defs back to the pending list for which we don't yet have
  2022. all method bodies }
  2023. for i:=0 to readdlist.count-1 do
  2024. current_module.pendingspecializations.add(tstoreddef(readdlist[i]).typename,readdlist[i]);
  2025. readdlist.free;
  2026. list.free;
  2027. end;
  2028. procedure generate_specializations_for_forwarddef(def:tdef);
  2029. var
  2030. list : tfpobjectlist;
  2031. idx,
  2032. i : longint;
  2033. context : tspecializationcontext;
  2034. begin
  2035. if not tstoreddef(def).is_generic then
  2036. internalerror(2020070304);
  2037. idx:=current_module.forwardgenericdefs.findindexof(def.fulltypename);
  2038. if idx<0 then
  2039. exit;
  2040. list:=tfpobjectlist(current_module.forwardgenericdefs.items[idx]);
  2041. if not assigned(list) then
  2042. internalerror(2020070305);
  2043. for i:=0 to list.count-1 do begin
  2044. context:=tspecializationcontext(list[i]);
  2045. generate_specialization_phase2(context,tstoreddef(def),false,'');
  2046. end;
  2047. current_module.forwardgenericdefs.delete(idx);
  2048. end;
  2049. procedure maybe_add_pending_specialization(def:tdef);
  2050. var
  2051. hmodule : tmodule;
  2052. st : tsymtable;
  2053. begin
  2054. if parse_generic then
  2055. exit;
  2056. st:=def.owner;
  2057. while st.symtabletype in [localsymtable] do
  2058. st:=st.defowner.owner;
  2059. hmodule:=find_module_from_symtable(st);
  2060. if tstoreddef(def).is_specialization and (hmodule=current_module) then
  2061. current_module.pendingspecializations.add(def.typename,def);
  2062. end;
  2063. function determine_generic_def(const name:tidstring):tstoreddef;
  2064. var
  2065. hashedid : THashedIDString;
  2066. pd : tprocdef;
  2067. sym : tsym;
  2068. begin
  2069. result:=nil;
  2070. { check whether this is a declaration of a type inside a
  2071. specialization }
  2072. if assigned(current_structdef) and
  2073. (df_specialization in current_structdef.defoptions) then
  2074. begin
  2075. if not assigned(current_structdef.genericdef) or
  2076. not (current_structdef.genericdef.typ in [recorddef,objectdef]) then
  2077. internalerror(2011052301);
  2078. hashedid.id:=name;
  2079. { we could be inside a method of the specialization
  2080. instead of its declaration, so check that first (as
  2081. local nested types aren't allowed we don't need to
  2082. walk the symtablestack to find the localsymtable) }
  2083. if symtablestack.top.symtabletype=localsymtable then
  2084. begin
  2085. { we are in a method }
  2086. if not assigned(symtablestack.top.defowner) or
  2087. (symtablestack.top.defowner.typ<>procdef) then
  2088. internalerror(2011120701);
  2089. pd:=tprocdef(symtablestack.top.defowner);
  2090. if not assigned(pd.genericdef) or (pd.genericdef.typ<>procdef) then
  2091. internalerror(2011120702);
  2092. sym:=tsym(tprocdef(pd.genericdef).localst.findwithhash(hashedid));
  2093. end
  2094. else
  2095. sym:=nil;
  2096. if not assigned(sym) or not (sym.typ=typesym) then
  2097. begin
  2098. { now search in the declaration of the generic }
  2099. sym:=tsym(tabstractrecorddef(current_structdef.genericdef).symtable.findwithhash(hashedid));
  2100. if not assigned(sym) or not (sym.typ=typesym) then
  2101. internalerror(2011052302);
  2102. end;
  2103. { use the corresponding type in the generic's symtable as
  2104. genericdef for the specialized type }
  2105. result:=tstoreddef(ttypesym(sym).typedef);
  2106. end;
  2107. end;
  2108. end.