pgenutil.pas 63 KB

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