pgenutil.pas 131 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184
  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. { node }
  29. node,
  30. { symtable }
  31. symtype,symdef,symbase;
  32. procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);inline;
  33. procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;const symname:string;symtable:tsymtable);inline;
  34. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean):tdef;inline;
  35. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;const symname:string;symtable:tsymtable):tdef;inline;
  36. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
  37. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;const _prettyname:ansistring):tdef;
  38. function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean;
  39. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  40. function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  41. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist;isfwd:boolean);
  42. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  43. function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:ansistring):tidstring;
  44. procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
  45. procedure add_generic_dummysym(sym:tsym;const name:tidstring);
  46. function resolve_generic_dummysym(const name:tidstring):tsym;
  47. function could_be_generic(const name:tidstring):boolean;inline;
  48. function try_implicit_specialization(sym:tsym;para:tnode;pdoverloadlist:tfpobjectlist;var unnamed_syms:tfplist;var first_procsym:tsym;var hasoverload:boolean):boolean;
  49. function finalize_specialization(var pd:tprocdef;spezcontext:tspecializationcontext):boolean;
  50. procedure generate_specialization_procs;
  51. procedure generate_specializations_for_forwarddef(def:tdef);
  52. procedure maybe_add_pending_specialization(def:tdef;unnamed_syms:tfplist);
  53. function determine_generic_def(const name:tidstring):tstoreddef;
  54. function is_or_belongs_to_current_genericdef(def:tdef):boolean;
  55. procedure specialization_init(genericdef:tdef;var state:tspecializationstate);
  56. procedure specialization_done(var state:tspecializationstate);
  57. implementation
  58. uses
  59. { common }
  60. cutils,fpchash,
  61. { global }
  62. globals,tokens,verbose,finput,constexp,
  63. { symtable }
  64. symconst,symsym,symtable,defcmp,defutil,procinfo,
  65. { modules }
  66. fmodule,
  67. { node }
  68. nobj,ncon,ncal,
  69. { parser }
  70. scanner,
  71. pbase,pexpr,pdecsub,ptype,psub,pparautl,pdecl,procdefutil;
  72. type
  73. tdeftypeset = set of tdeftyp;
  74. const
  75. tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,floatdef,setdef,pointerdef,enumdef];
  76. tgeneric_param_nodes : tnodetypeset = [typen,ordconstn,stringconstn,realconstn,setconstn,niln];
  77. procedure make_prettystring(paramtype:tdef;first:boolean;constprettyname:ansistring;var prettyname,specializename:ansistring);
  78. var
  79. namepart : string;
  80. prettynamepart : ansistring;
  81. module : tmodule;
  82. begin
  83. if assigned(paramtype.owner) then
  84. module:=find_module_from_symtable(paramtype.owner)
  85. else
  86. module:=current_module;
  87. if not assigned(module) then
  88. internalerror(2016112802);
  89. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+paramtype.unique_id_str;
  90. if constprettyname<>'' then
  91. namepart:=namepart+'$$'+constprettyname;
  92. { we use the full name of the type to uniquely identify it }
  93. if (symtablestack.top.symtabletype=parasymtable) and
  94. (symtablestack.top.defowner.typ=procdef) and
  95. (paramtype.owner=symtablestack.top) then
  96. begin
  97. { special handling for specializations inside generic function declarations }
  98. prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true,true)+tprocdef(symtablestack.top.defowner).procsym.prettyname;
  99. end
  100. else
  101. begin
  102. prettynamepart:=paramtype.fullownerhierarchyname(true,true);
  103. end;
  104. specializename:=specializename+namepart;
  105. if not first then
  106. prettyname:=prettyname+',';
  107. if constprettyname<>'' then
  108. prettyname:=prettyname+constprettyname
  109. else
  110. prettyname:=prettyname+prettynamepart+paramtype.typesym.prettyname;
  111. end;
  112. function get_generic_param_def(sym:tsym):tdef;
  113. begin
  114. if sym.typ=constsym then
  115. result:=tconstsym(sym).constdef
  116. else
  117. result:=ttypesym(sym).typedef;
  118. end;
  119. function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean;
  120. begin
  121. if (value.valueord<param2.low) or (value.valueord>param2.high) then
  122. result:=false
  123. else
  124. result:=true;
  125. end;
  126. function compare_generic_params(param1,param2:tdef;constparamsym:tconstsym):boolean;
  127. begin
  128. if (param1.typ=orddef) and (param2.typ=orddef) then
  129. begin
  130. if is_boolean(param2) then
  131. result:=is_boolean(param1)
  132. else if is_char(param2) then
  133. result:=is_char(param1)
  134. else if compare_orddef_by_range(torddef(param1),torddef(param2),constparamsym.value) then
  135. result:=true
  136. else
  137. result:=false;
  138. end
  139. { arraydef is string constant so it's compatible with stringdef }
  140. else if (param1.typ=arraydef) and (param2.typ=stringdef) then
  141. result:=true
  142. { integer ords are compatible with float }
  143. else if (param1.typ=orddef) and is_integer(param1) and (param2.typ=floatdef) then
  144. result:=true
  145. { chars are compatible with stringdef }
  146. else if (param1.typ=orddef) and is_char(param1) and (param2.typ=stringdef) then
  147. result:=true
  148. { undefined def is compatible with all types }
  149. else if param2.typ=undefineddef then
  150. result:=true
  151. { sets require stricter checks }
  152. else if is_set(param2) then
  153. result:=equal_defs(param1,param2) or
  154. { constant could be empty set }
  155. not(assigned(tsetdef(param1).elementdef))
  156. else
  157. result:=param1.typ=param2.typ;
  158. end;
  159. function create_generic_constsym(fromdef:tdef;node:tnode;out prettyname:string):tconstsym;
  160. const
  161. undefinedname = 'undefined';
  162. var
  163. sym : tconstsym;
  164. setdef : tsetdef;
  165. enumsym : tsym;
  166. enumname : string;
  167. sp : pchar;
  168. ps : ^tconstset;
  169. pd : ^bestreal;
  170. i,l : integer;
  171. begin
  172. if node=nil then
  173. internalerror(2020011401);
  174. case node.nodetype of
  175. ordconstn:
  176. begin
  177. sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef);
  178. prettyname:=tostr(tordconstnode(node).value.svalue);
  179. end;
  180. stringconstn:
  181. begin
  182. // unicode, convert to utf8
  183. if tstringconstnode(node).cst_type in [cst_widestring,cst_unicodestring] then
  184. begin
  185. l:=UnicodeToUtf8(nil,0,tstringconstnode(node).valuews.asconstpunicodechar,tstringconstnode(node).valuews.len);
  186. getmem(sp,l);
  187. UnicodeToUtf8(sp,l,tstringconstnode(node).valuews.asconstpunicodechar,tstringconstnode(node).valuews.len);
  188. sym:=cconstsym.create_string(undefinedname,conststring,sp,l,fromdef);
  189. prettyname:=''''+sp+'''';
  190. end
  191. else
  192. begin
  193. getmem(sp,tstringconstnode(node).len+1);
  194. move(tstringconstnode(node).asconstpchar^,sp^,tstringconstnode(node).len+1);
  195. sym:=cconstsym.create_string(undefinedname,conststring,sp,tstringconstnode(node).len,fromdef);
  196. prettyname:=''''+tstringconstnode(node).asconstpchar+'''';
  197. end;
  198. end;
  199. realconstn:
  200. begin
  201. new(pd);
  202. pd^:=trealconstnode(node).value_real;
  203. sym:=cconstsym.create_ptr(undefinedname,constreal,pd,fromdef);
  204. prettyname:=realtostr(trealconstnode(node).value_real);
  205. end;
  206. setconstn:
  207. begin
  208. new(ps);
  209. ps^:=tsetconstnode(node).value_set^;
  210. sym:=cconstsym.create_ptr(undefinedname,constset,ps,fromdef);
  211. setdef:=tsetdef(tsetconstnode(node).resultdef);
  212. prettyname:='[';
  213. for i := setdef.setbase to setdef.setmax do
  214. if i in tsetconstnode(node).value_set^ then
  215. begin
  216. if setdef.elementdef.typ=enumdef then
  217. enumsym:=tenumdef(setdef.elementdef).int2enumsym(i)
  218. else
  219. enumsym:=nil;
  220. if assigned(enumsym) then
  221. enumname:=enumsym.realname
  222. else if setdef.elementdef.typ=orddef then
  223. begin
  224. if torddef(setdef.elementdef).ordtype=uchar then
  225. enumname:=chr(i)
  226. else
  227. enumname:=tostr(i);
  228. end
  229. else
  230. enumname:=tostr(i);
  231. if length(prettyname) > 1 then
  232. prettyname:=prettyname+','+enumname
  233. else
  234. prettyname:=prettyname+enumname;
  235. end;
  236. prettyname:=prettyname+']';
  237. end;
  238. niln:
  239. begin
  240. { only "nil" is available for pointer constants }
  241. sym:=cconstsym.create_ord(undefinedname,constnil,0,fromdef);
  242. prettyname:='nil';
  243. end;
  244. else
  245. internalerror(2019021601);
  246. end;
  247. { the sym needs an owner for later checks so use the typeparam owner }
  248. sym.owner:=fromdef.owner;
  249. include(sym.symoptions,sp_generic_const);
  250. result:=sym;
  251. end;
  252. procedure maybe_add_waiting_unit(tt:tdef);
  253. var
  254. hmodule : tmodule;
  255. begin
  256. if not assigned(tt) or
  257. not (df_generic in tt.defoptions) then
  258. exit;
  259. hmodule:=find_module_from_symtable(tt.owner);
  260. if not assigned(hmodule) then
  261. internalerror(2012092401);
  262. if hmodule=current_module then
  263. exit;
  264. if (hmodule.state = ms_load) and hmodule.interface_compiled then
  265. Exit;
  266. if not (hmodule.state in [ms_compiling_waitfinish,ms_compiled_waitcrc,ms_compiled,ms_processed]) then
  267. begin
  268. {$ifdef DEBUG_UNITWAITING}
  269. Writeln('Unit ', current_module.modulename^,
  270. ' waiting for ', hmodule.modulename^);
  271. {$endif DEBUG_UNITWAITING}
  272. if current_module.waitingforunit.indexof(hmodule)<0 then
  273. current_module.waitingforunit.add(hmodule);
  274. if hmodule.waitingunits.indexof(current_module)<0 then
  275. hmodule.waitingunits.add(current_module);
  276. end;
  277. end;
  278. procedure add_forward_generic_def(def:tdef;context:tspecializationcontext);
  279. var
  280. list : tfpobjectlist;
  281. fwdcontext : tspecializationcontext;
  282. begin
  283. if not is_implicit_pointer_object_type(def) then
  284. internalerror(2020070301);
  285. if not (oo_is_forward in tobjectdef(def).objectoptions) then
  286. internalerror(2020070302);
  287. if not assigned(tobjectdef(def).genericdef) then
  288. internalerror(2020070303);
  289. list:=tfpobjectlist(current_module.forwardgenericdefs.find(tobjectdef(def).genericdef.fulltypename));
  290. if not assigned(list) then
  291. begin
  292. list:=tfpobjectlist.create(true);
  293. current_module.forwardgenericdefs.add(tobjectdef(def).genericdef.fulltypename,list);
  294. end;
  295. fwdcontext:=context.getcopy;
  296. fwdcontext.forwarddef:=def;
  297. list.add(fwdcontext);
  298. end;
  299. function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean;
  300. var
  301. i,j,
  302. intfcount : longint;
  303. formaldef,
  304. paradef : tstoreddef;
  305. genparadef : tdef;
  306. objdef,
  307. paraobjdef,
  308. formalobjdef : tobjectdef;
  309. intffound : boolean;
  310. filepos : tfileposinfo;
  311. is_const : boolean;
  312. begin
  313. { check whether the given specialization parameters fit to the eventual
  314. constraints of the generic }
  315. if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then
  316. internalerror(2012101001);
  317. if genericdef.genericparas.count<>paramlist.count then
  318. internalerror(2012101002);
  319. if paramlist.count<>poslist.count then
  320. internalerror(2012120801);
  321. result:=true;
  322. for i:=0 to genericdef.genericparas.count-1 do
  323. begin
  324. filepos:=pfileposinfo(poslist[i])^;
  325. paradef:=tstoreddef(get_generic_param_def(tsym(paramlist[i])));
  326. is_const:=tsym(paramlist[i]).typ=constsym;
  327. genparadef:=genericdef.get_generic_param_def(i);
  328. { validate const params }
  329. if not genericdef.is_generic_param_const(i) and is_const then
  330. begin
  331. MessagePos(filepos,type_e_mismatch);
  332. exit(false);
  333. end
  334. else if genericdef.is_generic_param_const(i) then
  335. begin
  336. { param type mismatch (type <> const) }
  337. if genericdef.is_generic_param_const(i)<>is_const then
  338. begin
  339. MessagePos(filepos,type_e_mismatch);
  340. exit(false);
  341. end;
  342. { type constrained param doesn't match type }
  343. if not compare_generic_params(paradef,genericdef.get_generic_param_def(i),tconstsym(paramlist[i])) then
  344. begin
  345. MessagePos2(filepos,type_e_incompatible_types,FullTypeName(paradef,genparadef),FullTypeName(genparadef,paradef));
  346. exit(false);
  347. end;
  348. end;
  349. { test constraints for non-const params }
  350. if not genericdef.is_generic_param_const(i) then
  351. begin
  352. formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef);
  353. if formaldef.typ=undefineddef then
  354. { the parameter is of unspecified type, so no need to check }
  355. continue;
  356. if not (df_genconstraint in formaldef.defoptions) or
  357. not assigned(formaldef.genconstraintdata) then
  358. internalerror(2013021602);
  359. { undefineddef is compatible with anything }
  360. if formaldef.typ=undefineddef then
  361. continue;
  362. if paradef.typ<>formaldef.typ then
  363. begin
  364. case formaldef.typ of
  365. recorddef:
  366. { delphi has own fantasy about record constraint
  367. (almost non-nullable/non-nil-able value type) }
  368. if m_delphi in current_settings.modeswitches then
  369. case paradef.typ of
  370. floatdef,enumdef,orddef:
  371. continue;
  372. objectdef:
  373. if tobjectdef(paradef).objecttype=odt_object then
  374. continue
  375. else
  376. MessagePos(filepos,type_e_record_type_expected);
  377. else
  378. MessagePos(filepos,type_e_record_type_expected);
  379. end
  380. else
  381. MessagePos(filepos,type_e_record_type_expected);
  382. objectdef:
  383. case tobjectdef(formaldef).objecttype of
  384. odt_class,
  385. odt_javaclass:
  386. MessagePos1(filepos,type_e_class_type_expected,paradef.typename);
  387. odt_interfacecom,
  388. odt_interfacecorba,
  389. odt_dispinterface,
  390. odt_interfacejava:
  391. MessagePos1(filepos,type_e_interface_type_expected,paradef.typename);
  392. else
  393. internalerror(2012101003);
  394. end;
  395. errordef:
  396. { ignore }
  397. ;
  398. else
  399. internalerror(2012101004);
  400. end;
  401. result:=false;
  402. end
  403. else
  404. begin
  405. { the paradef types are the same, so do special checks for the
  406. cases in which they are needed }
  407. if formaldef.typ=objectdef then
  408. begin
  409. paraobjdef:=tobjectdef(paradef);
  410. formalobjdef:=tobjectdef(formaldef);
  411. if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then
  412. internalerror(2012101102);
  413. if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then
  414. begin
  415. { this is either a concrete interface or class type (the
  416. latter without specific implemented interfaces) }
  417. case paraobjdef.objecttype of
  418. odt_interfacecom,
  419. odt_interfacecorba,
  420. odt_interfacejava,
  421. odt_dispinterface:
  422. begin
  423. if (oo_is_forward in paraobjdef.objectoptions) and
  424. (paraobjdef.objecttype=formalobjdef.objecttype) and
  425. (df_genconstraint in formalobjdef.defoptions) and
  426. (
  427. (formalobjdef.objecttype=odt_interfacecom) and
  428. (formalobjdef.childof=interface_iunknown)
  429. )
  430. or
  431. (
  432. (formalobjdef.objecttype=odt_interfacecorba) and
  433. (formalobjdef.childof=nil)
  434. ) then
  435. continue;
  436. if not def_is_related(paraobjdef,formalobjdef.childof) then
  437. begin
  438. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  439. result:=false;
  440. end;
  441. end;
  442. odt_class,
  443. odt_javaclass:
  444. begin
  445. objdef:=paraobjdef;
  446. intffound:=false;
  447. while assigned(objdef) do
  448. begin
  449. for j:=0 to objdef.implementedinterfaces.count-1 do
  450. if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then
  451. begin
  452. intffound:=true;
  453. break;
  454. end;
  455. if intffound then
  456. break;
  457. objdef:=objdef.childof;
  458. end;
  459. result:=intffound;
  460. if not result then
  461. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename);
  462. end;
  463. else
  464. begin
  465. MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename);
  466. result:=false;
  467. end;
  468. end;
  469. end
  470. else
  471. begin
  472. { this is either a "class" or a concrete instance with
  473. or without implemented interfaces }
  474. if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then
  475. begin
  476. MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename);
  477. result:=false;
  478. continue;
  479. end;
  480. { for forward declared classes we allow pure TObject/class declarations }
  481. if (oo_is_forward in paraobjdef.objectoptions) and
  482. (df_genconstraint in formaldef.defoptions) then
  483. begin
  484. if (formalobjdef.childof=class_tobject) and
  485. not formalobjdef.implements_any_interfaces then
  486. continue;
  487. end;
  488. if assigned(formalobjdef.childof) and
  489. not def_is_related(paradef,formalobjdef.childof) then
  490. begin
  491. MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename);
  492. result:=false;
  493. end;
  494. intfcount:=0;
  495. for j:=0 to formalobjdef.implementedinterfaces.count-1 do
  496. begin
  497. objdef:=paraobjdef;
  498. intffound:=false;
  499. while assigned(objdef) do
  500. begin
  501. intffound:=assigned(
  502. find_implemented_interface(objdef,
  503. timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef
  504. )
  505. );
  506. if intffound then
  507. break;
  508. objdef:=objdef.childof;
  509. end;
  510. if intffound then
  511. inc(intfcount)
  512. else
  513. MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename);
  514. end;
  515. if intfcount<>formalobjdef.implementedinterfaces.count then
  516. result:=false;
  517. end;
  518. end;
  519. end;
  520. end;
  521. end;
  522. end;
  523. function parse_generic_specialization_types_internal(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
  524. var
  525. old_block_type : tblock_type;
  526. first : boolean;
  527. typeparam : tnode;
  528. parampos : pfileposinfo;
  529. tmpparampos : tfileposinfo;
  530. namepart : string;
  531. module : tmodule;
  532. constprettyname : string;
  533. validparam : boolean;
  534. begin
  535. result:=true;
  536. prettyname:='';
  537. constprettyname:='';
  538. if paramlist=nil then
  539. internalerror(2012061401);
  540. { set the block type to type, so that the parsed type are returned as
  541. ttypenode (e.g. classes are in non type-compatible blocks returned as
  542. tloadvmtaddrnode) }
  543. old_block_type:=block_type;
  544. { if parsedtype is set, then the first type identifer was already parsed
  545. (happens in inline specializations) and thus we only need to parse
  546. the remaining types and do as if the first one was already given }
  547. first:=not assigned(parsedtype);
  548. if assigned(parsedtype) then
  549. begin
  550. paramlist.Add(parsedtype.typesym);
  551. module:=find_module_from_symtable(parsedtype.owner);
  552. if not assigned(module) then
  553. internalerror(2016112801);
  554. namepart:='_$'+hexstr(module.moduleid,8)+'$$'+parsedtype.unique_id_str;
  555. specializename:='$'+namepart;
  556. prettyname:=parsedtype.fullownerhierarchyname(true,true)+parsedtype.typesym.prettyname;
  557. if assigned(poslist) then
  558. begin
  559. New(parampos);
  560. parampos^:=parsedpos;
  561. poslist.add(parampos);
  562. end;
  563. end
  564. else
  565. specializename:='$';
  566. while not (token in [_GT,_RSHARPBRACKET]) do
  567. begin
  568. { "first" is set to false at the end of the loop! }
  569. if not first then
  570. consume(_COMMA);
  571. block_type:=bt_type;
  572. tmpparampos:=current_filepos;
  573. typeparam:=factor(false,[ef_accept_equal]);
  574. { determine if the typeparam node is a valid type or const }
  575. validparam:=typeparam.nodetype in tgeneric_param_nodes;
  576. if validparam then
  577. begin
  578. if tstoreddef(typeparam.resultdef).is_generic and
  579. not is_or_belongs_to_current_genericdef(typeparam.resultdef) and
  580. (
  581. not parse_generic or
  582. not defs_belong_to_same_generic(typeparam.resultdef,current_genericdef)
  583. ) then
  584. Message(parser_e_no_generics_as_params);
  585. if assigned(poslist) then
  586. begin
  587. New(parampos);
  588. parampos^:=tmpparampos;
  589. poslist.add(parampos);
  590. end;
  591. if typeparam.resultdef.typ<>errordef then
  592. begin
  593. if (typeparam.nodetype=typen) and not assigned(typeparam.resultdef.typesym) then
  594. message(type_e_generics_cannot_reference_itself)
  595. else if (typeparam.resultdef.typ<>errordef) then
  596. begin
  597. { all non-type nodes are considered const }
  598. if typeparam.nodetype<>typen then
  599. paramlist.Add(create_generic_constsym(typeparam.resultdef,typeparam,constprettyname))
  600. else
  601. begin
  602. constprettyname:='';
  603. paramlist.Add(typeparam.resultdef.typesym);
  604. end;
  605. make_prettystring(typeparam.resultdef,first,constprettyname,prettyname,specializename);
  606. end;
  607. end
  608. else
  609. begin
  610. result:=false;
  611. end;
  612. end
  613. else
  614. begin
  615. Message(type_e_type_id_expected);
  616. result:=false;
  617. end;
  618. typeparam.free;
  619. typeparam := nil;
  620. first:=false;
  621. end;
  622. block_type:=old_block_type;
  623. end;
  624. function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean;
  625. var
  626. dummypos : tfileposinfo;
  627. begin
  628. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  629. result:=parse_generic_specialization_types_internal(paramlist,poslist,prettyname,specializename,nil,dummypos);
  630. end;
  631. procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;const symname:string;symtable:tsymtable);
  632. var
  633. context : tspecializationcontext;
  634. genericdef : tstoreddef;
  635. dummypos : tfileposinfo;
  636. begin
  637. FillChar(dummypos, SizeOf(tfileposinfo), 0);
  638. genericdef:=tstoreddef(generate_specialization_phase1(context,tt,enforce_unit,nil,symname,symtable,dummypos));
  639. if genericdef<>generrordef then
  640. genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname));
  641. tt:=genericdef;
  642. if assigned(context) then
  643. context.free; // no nil needed
  644. end;
  645. function finalize_specialization(var pd:tprocdef;spezcontext:tspecializationcontext):boolean;
  646. var
  647. def : tdef;
  648. begin
  649. result:=false;
  650. if assigned(spezcontext) then
  651. begin
  652. if not (df_generic in pd.defoptions) then
  653. internalerror(2015060301);
  654. { check whether the given parameters are compatible
  655. to the def's constraints }
  656. if not check_generic_constraints(pd,spezcontext.paramlist,spezcontext.poslist) then
  657. exit;
  658. def:=generate_specialization_phase2(spezcontext,pd,false,'');
  659. case def.typ of
  660. errordef:
  661. { do nothing }
  662. ;
  663. procdef:
  664. pd:=tprocdef(def);
  665. else
  666. internalerror(2015070303);
  667. end;
  668. end;
  669. result:=true;
  670. end;
  671. procedure transfer_unnamed_symbols(owner:tsymtable;unnamed_syms:tfplist);
  672. var
  673. i : integer;
  674. sym : tsym;
  675. begin
  676. for i:=0 to unnamed_syms.count-1 do
  677. begin
  678. sym:=tsym(unnamed_syms[i]);
  679. sym.ChangeOwnerAndName(owner,sym.realname);
  680. end;
  681. unnamed_syms.clear;
  682. end;
  683. function try_implicit_specialization(sym:tsym;para:tnode;pdoverloadlist:tfpobjectlist;var unnamed_syms:tfplist;var first_procsym:tsym;var hasoverload:boolean):boolean;
  684. { hash key for generic parameter lookups }
  685. function generic_param_hash(def:tdef):string;inline;
  686. begin
  687. result:=def.typename;
  688. end;
  689. { returns true if the def a literal array such as [1,2,3] and not a shortstring }
  690. function is_array_literal(def:tdef):boolean;
  691. begin
  692. result:=(def.typ=arraydef) and not is_conststring_array(def);
  693. end;
  694. { makes the specialization context from the generic proc def and generic params }
  695. procedure generate_implicit_specialization(out context:tspecializationcontext;genericdef:tprocdef;genericparams:tfphashlist);
  696. var
  697. parsedpos:tfileposinfo;
  698. poslist:tfplist;
  699. i: longint;
  700. paramtype: ttypesym;
  701. parampos : pfileposinfo;
  702. tmpparampos : tfileposinfo;
  703. paramname: string;
  704. begin
  705. context:=tspecializationcontext.create;
  706. fillchar(parsedpos,sizeof(parsedpos),0);
  707. poslist:=context.poslist;
  708. tmpparampos:=current_filepos;
  709. if genericparams.count<>genericdef.genericparas.count then
  710. internalerror(2021020901);
  711. poslist.capacity:=poslist.count+genericparams.count;
  712. context.paramlist.capacity:=context.paramlist.count+genericparams.count;
  713. for i:=0 to genericparams.count-1 do
  714. begin
  715. paramname:=generic_param_hash(ttypesym(genericdef.genericparas[i]).typedef);
  716. paramtype:=ttypesym(genericparams.find(paramname));
  717. if not assigned(paramtype) then
  718. internalerror(2021020902);
  719. new(parampos);
  720. parampos^:=tmpparampos;
  721. poslist.add(parampos);
  722. context.paramlist.Add(paramtype);
  723. make_prettystring(paramtype.typedef,i=0,'',context.prettyname,context.specializename);
  724. end;
  725. context.genname:=genericdef.procsym.realname;
  726. end;
  727. { specialization context parameter lists require a typesym so we need
  728. to generate a placeholder for unnamed constant types like
  729. short strings, open arrays, function pointers etc... }
  730. function create_unnamed_typesym(def:tdef):tsym;
  731. var
  732. newtype: tsym;
  733. begin
  734. newtype:=nil;
  735. if is_conststring_array(def) then
  736. begin
  737. { for constant strings we need to respect various modeswitches }
  738. if (cs_refcountedstrings in current_settings.localswitches) then
  739. begin
  740. if m_default_unicodestring in current_settings.modeswitches then
  741. newtype:=cunicodestringtype.typesym
  742. else
  743. newtype:=cansistringtype.typesym;
  744. end
  745. else
  746. newtype:=cshortstringtype.typesym;
  747. end
  748. else if def.typ=stringdef then
  749. newtype:=tstringdef(def).get_default_string_type.typesym
  750. else
  751. begin
  752. if is_array_constructor(def) then
  753. begin
  754. { array constructor is not a valid parameter type; getreusable
  755. avoids creating multiple implementations for calls with the
  756. same number of array elements of a particular type }
  757. def:=carraydef.getreusable(tarraydef(def).elementdef,tarraydef(def).highrange-tarraydef(def).lowrange+1);
  758. end;
  759. newtype:=ctypesym.create(def.fullownerhierarchyname(false,true)+typName[def.typ]+'$'+def.unique_id_str,def);
  760. include(newtype.symoptions,sp_generic_unnamed_type);
  761. newtype.owner:=def.owner;
  762. { ensure that there's no warning }
  763. newtype.refs:=1;
  764. end;
  765. if not assigned(newtype) then
  766. internalerror(2021020904);
  767. result:=newtype;
  768. end;
  769. { searches for the generic param in specializations }
  770. function find_param_in_specialization(owner:tprocdef;genericparam:ttypesym;def:tstoreddef):boolean;
  771. var
  772. parasym: ttypesym;
  773. k, i: integer;
  774. begin
  775. result:=false;
  776. for i:=0 to def.genericparas.count-1 do
  777. begin
  778. parasym:=ttypesym(def.genericparas[i]);
  779. { the generic param must have a named typesym }
  780. if not assigned(parasym.typedef.typesym) then
  781. internalerror(2021020907);
  782. { recurse into inline specialization }
  783. if tstoreddef(parasym.typedef).is_specialization then
  784. begin
  785. result:=find_param_in_specialization(owner,genericparam,tstoreddef(parasym.typedef));
  786. if result then
  787. exit;
  788. end
  789. else if (genericparam=parasym.typedef.typesym) and owner.is_generic_param(parasym.typedef) then
  790. exit(true);
  791. end;
  792. end;
  793. { searches for the generic param in arrays }
  794. function find_param_in_array(owner:tprocdef;genericparam:ttypesym;def:tarraydef):boolean;
  795. var
  796. elementdef:tstoreddef;
  797. begin
  798. elementdef:=tstoreddef(def.elementdef);
  799. { recurse into multi-dimensional array }
  800. if elementdef.typ=arraydef then
  801. result:=find_param_in_array(owner,genericparam,tarraydef(elementdef))
  802. { something went wrong during parsing and the element is invalid }
  803. else if elementdef.typ=errordef then
  804. result:=false
  805. else
  806. begin
  807. { the element must have a named typesym }
  808. if not assigned(elementdef.typesym) then
  809. internalerror(2021020906);
  810. result:=(genericparam=elementdef.typesym) and owner.is_generic_param(elementdef);
  811. end;
  812. end;
  813. { tests if the generic param is used in the parameter list }
  814. function is_generic_param_used(owner:tprocdef;genericparam:ttypesym;paras:tfplist):boolean;
  815. var
  816. paravar:tparavarsym;
  817. i: integer;
  818. begin
  819. result:=false;
  820. for i:=0 to paras.count-1 do
  821. begin
  822. paravar:=tparavarsym(paras[i]);
  823. { handle array types by using element types (for example: array of T) }
  824. if paravar.vardef.typ=arraydef then
  825. result:=find_param_in_array(owner,genericparam,tarraydef(paravar.vardef))
  826. { for specializations check search in generic params }
  827. else if tstoreddef(paravar.vardef).is_specialization then
  828. result:=find_param_in_specialization(owner,genericparam,tstoreddef(paravar.vardef))
  829. { something went wrong during parsing and the parameter is invalid }
  830. else if paravar.vardef.typ=errordef then
  831. exit(false)
  832. else
  833. begin
  834. if not assigned(paravar.vardef.typesym) then
  835. internalerror(2021020905);
  836. result:=(genericparam=paravar.vardef.typesym) and owner.is_generic_param(paravar.vardef)
  837. end;
  838. { exit if we find a used parameter }
  839. if result then
  840. exit;
  841. end;
  842. end;
  843. { handle generic specializations by using generic params from caller
  844. to specialize the target. for example "TRec<Integer>" can use "Integer"
  845. to specialize "TRec<T>" with "Integer" for "T". }
  846. procedure handle_specializations(genericparams:tfphashlist;target_def,caller_def:tstoreddef);
  847. var
  848. i,
  849. index : integer;
  850. key : string;
  851. target_param,
  852. caller_param : ttypesym;
  853. begin
  854. { the target and the caller must the same generic def
  855. with the same set of generic parameters }
  856. if target_def.genericdef<>caller_def.genericdef then
  857. internalerror(2021020909);
  858. for i:=0 to target_def.genericparas.count-1 do
  859. begin
  860. target_param:=ttypesym(target_def.genericparas[i]);
  861. caller_param:=ttypesym(caller_def.genericparas[i]);
  862. { reject generics with constants }
  863. if (target_param.typ=constsym) or (caller_param.typ=constsym) then
  864. exit;
  865. key:=generic_param_hash(target_param.typedef);
  866. { the generic param is already used }
  867. index:=genericparams.findindexof(key);
  868. if index>=0 then
  869. continue;
  870. { add the type to the generic params }
  871. genericparams.add(key,caller_param);
  872. end;
  873. end;
  874. { specialize arrays by using element types but arrays may be multi-dimensional
  875. so we need to examine the caller/target pairs recursively in order to
  876. verify the dimensionality is equal }
  877. function handle_arrays(owner:tprocdef;target_def,caller_def:tarraydef;out target_element,caller_element:tdef):boolean;
  878. begin
  879. { the target and the caller are both arrays and the target is a
  880. specialization so we can recurse into the targets element def }
  881. if is_array_literal(target_def.elementdef) and
  882. is_array_literal(caller_def.elementdef) and
  883. target_def.is_specialization then
  884. result:=handle_arrays(owner,tarraydef(target_def.elementdef),tarraydef(caller_def.elementdef),target_element,caller_element)
  885. else
  886. begin
  887. { the caller is an array which means the dimensionality is unbalanced
  888. and thus the arrays are compatible }
  889. if is_array_literal(caller_def.elementdef) then
  890. exit(false);
  891. { if the element is a generic param then return this type
  892. along with the caller element type at the same level }
  893. result:=owner.is_generic_param(target_def.elementdef);
  894. if result then
  895. begin
  896. target_element:=target_def.elementdef;
  897. caller_element:=caller_def.elementdef;
  898. end;
  899. end;
  900. end;
  901. { handle procvars by using the parameters from the caller to specialize
  902. the parameters of the target generic procedure specialization. for example:
  903. type generic TProc<S> = procedure(value: S);
  904. generic procedure Run<T>(proc: specialize TProc<T>);
  905. procedure DoCallback(value: integer);
  906. Run(@DoCallback);
  907. will specialize as Run<integer> because the signature
  908. of DoCallback() matches TProc<S> so we can specialize "S"
  909. with "integer", as they are both parameter #1
  910. }
  911. function handle_procvars(genericparams:tfphashlist;callerparams:tfplist;target_def:tdef;caller_def:tdef):boolean;
  912. var
  913. newparams : tfphashlist;
  914. procedure handle_generic_param(targetparadef,callerparadef:tdef);
  915. var
  916. key : string;
  917. index : integer;
  918. begin
  919. if not assigned(callerparadef.typesym) then
  920. internalerror(2021020908);
  921. key:=generic_param_hash(targetparadef);
  922. { the generic param must not already be used }
  923. index:=genericparams.findindexof(key);
  924. if index<0 then
  925. begin
  926. { add the type to the list }
  927. index:=newparams.findindexof(key);
  928. if index<0 then
  929. newparams.add(key,callerparadef.typesym);
  930. end;
  931. end;
  932. var
  933. i,j : integer;
  934. paravar : tparavarsym;
  935. target_proc,
  936. caller_proc : tprocvardef;
  937. target_proc_para,
  938. caller_proc_para : tparavarsym;
  939. valid_params : integer;
  940. begin
  941. result := false;
  942. target_proc:=tprocvardef(target_def);
  943. caller_proc:=tprocvardef(caller_def);
  944. { parameter count must match exactly
  945. currently default values are not considered }
  946. if target_proc.paras.count<>caller_proc.paras.count then
  947. exit;
  948. { a mixture of functions and procedures is not allowed }
  949. if (not assigned(target_proc.returndef) or is_void(target_proc.returndef)) xor
  950. (not assigned(caller_proc.returndef) or is_void(caller_proc.returndef)) then
  951. exit;
  952. { reject generics with constants }
  953. for i:=0 to target_proc.genericdef.genericparas.count-1 do
  954. if tsym(target_proc.genericdef.genericparas[i]).typ=constsym then
  955. exit;
  956. newparams:=tfphashlist.create;
  957. valid_params:=0;
  958. for i:=0 to target_proc.paras.count-1 do
  959. begin
  960. target_proc_para:=tparavarsym(target_proc.paras[i]);
  961. caller_proc_para:=tparavarsym(caller_proc.paras[i]);
  962. { the parameters are not compatible }
  963. if compare_defs(caller_proc_para.vardef,target_proc_para.vardef,nothingn)=te_incompatible then
  964. begin
  965. newparams.free;
  966. newparams := nil;
  967. exit(false);
  968. end;
  969. if sp_generic_para in target_proc_para.vardef.typesym.symoptions then
  970. begin
  971. paravar:=tparavarsym(tprocvardef(target_proc.genericdef).paras[i]);
  972. { find the generic param name in the generic def parameters }
  973. j:=target_proc.genericdef.genericparas.findindexof(paravar.vardef.typesym.name);
  974. handle_generic_param(ttypesym(target_proc.genericparas[j]).typedef,caller_proc_para.vardef);
  975. end;
  976. inc(valid_params);
  977. end;
  978. if assigned(target_proc.returndef) and not is_void(target_proc.returndef) then
  979. begin
  980. { or check for exact? }
  981. if compare_defs(caller_proc.returndef,target_proc.returndef,nothingn)<te_equal then
  982. begin
  983. newparams.free;
  984. newparams := nil;
  985. exit(false);
  986. end;
  987. if sp_generic_para in target_proc.returndef.typesym.symoptions then
  988. begin
  989. handle_generic_param(target_proc.returndef,caller_proc.returndef);
  990. end;
  991. end;
  992. { if the count of valid params matches the target then
  993. transfer the temporary params to the actual params }
  994. result:=valid_params=target_proc.paras.count;
  995. if result then
  996. for i := 0 to newparams.count-1 do
  997. genericparams.add(newparams.nameofindex(i),newparams[i]);
  998. newparams.free;
  999. newparams := nil;
  1000. end;
  1001. function maybe_inherited_specialization(givendef,desireddef:tstoreddef;out basedef:tstoreddef):boolean;
  1002. begin
  1003. result:=false;
  1004. basedef:=nil;
  1005. if givendef.typ<>objectdef then
  1006. begin
  1007. result:=givendef.is_specialization and (givendef.genericdef=desireddef.genericdef);
  1008. if result then
  1009. basedef:=givendef;
  1010. end
  1011. else
  1012. begin
  1013. while assigned(givendef) do
  1014. begin
  1015. if givendef.is_specialization and (givendef.genericdef=desireddef.genericdef) then
  1016. begin
  1017. basedef:=givendef;
  1018. result:=true;
  1019. break;
  1020. end;
  1021. givendef:=tobjectdef(givendef).childof;
  1022. end;
  1023. end;
  1024. end;
  1025. { compare generic parameters <T> with call node parameters. }
  1026. function is_possible_specialization(callerparams:tfplist;genericdef:tprocdef;out unnamed_syms:tfplist;out genericparams:tfphashlist):boolean;
  1027. var
  1028. i,j,
  1029. count : integer;
  1030. paravar : tparavarsym;
  1031. base_def : tstoreddef;
  1032. target_def,
  1033. caller_def : tdef;
  1034. target_key : string;
  1035. index : integer;
  1036. paras : tfplist;
  1037. target_element,
  1038. caller_element : tdef;
  1039. required_param_count : integer;
  1040. adef : tarraydef;
  1041. begin
  1042. result:=false;
  1043. paras:=nil;
  1044. genericparams:=nil;
  1045. required_param_count:=0;
  1046. unnamed_syms:=nil;
  1047. { first perform a check to reject generics with constants }
  1048. for i:=0 to genericdef.genericparas.count-1 do
  1049. if tsym(genericdef.genericparas[i]).typ=constsym then
  1050. exit;
  1051. { build list of visible target function parameters }
  1052. paras:=tfplist.create;
  1053. for i:=0 to genericdef.paras.count-1 do
  1054. begin
  1055. paravar:=tparavarsym(genericdef.paras[i]);
  1056. { ignore hidden parameters }
  1057. if vo_is_hidden_para in paravar.varoptions then
  1058. continue;
  1059. paras.add(paravar);
  1060. { const non-default parameters are required }
  1061. if not assigned(paravar.defaultconstsym) then
  1062. inc(required_param_count);
  1063. end;
  1064. { not enough parameters were supplied }
  1065. if callerparams.count<required_param_count then
  1066. begin
  1067. paras.free;
  1068. paras := nil;
  1069. exit;
  1070. end;
  1071. { check to make sure the generic parameters are all used
  1072. at least once in the caller parameters. }
  1073. count:=0;
  1074. for i:=0 to genericdef.genericparas.count-1 do
  1075. if is_generic_param_used(genericdef,ttypesym(genericdef.genericparas[i]),paras) then
  1076. inc(count);
  1077. if count<genericdef.genericparas.count then
  1078. begin
  1079. paras.free;
  1080. paras := nil;
  1081. exit;
  1082. end;
  1083. genericparams:=tfphashlist.create;
  1084. for i:=0 to callerparams.count-1 do
  1085. begin
  1086. caller_def:=ttypesym(callerparams[i]).typedef;
  1087. { caller parameter exceeded the possible parameters }
  1088. if i=paras.count then
  1089. begin
  1090. genericparams.free;
  1091. genericparams := nil;
  1092. paras.free;
  1093. paras := nil;
  1094. exit;
  1095. end;
  1096. target_def:=tparavarsym(paras[i]).vardef;
  1097. target_key:='';
  1098. { strings are compatible with "array of T" so we
  1099. need to use the element type for specialization }
  1100. if is_stringlike(caller_def) and
  1101. is_array_literal(target_def) and
  1102. genericdef.is_generic_param(tarraydef(target_def).elementdef) then
  1103. begin
  1104. target_def:=tarraydef(target_def).elementdef;
  1105. target_key:=generic_param_hash(target_def);
  1106. caller_def:=chartype_for_stringlike(caller_def);
  1107. end
  1108. { non-uniform array constructors (i.e. array of const) are not compatible
  1109. with normal arrays like "array of T" so we reject them }
  1110. else if is_array_literal(target_def) and
  1111. (caller_def.typ=arraydef) and
  1112. (ado_IsConstructor in tarraydef(caller_def).arrayoptions) and
  1113. (ado_IsArrayOfConst in tarraydef(caller_def).arrayoptions) then
  1114. begin
  1115. continue;
  1116. end
  1117. { handle generic arrays }
  1118. else if is_array_literal(caller_def) and
  1119. is_array_literal(target_def) and
  1120. handle_arrays(genericdef,tarraydef(target_def),tarraydef(caller_def),target_element,caller_element) then
  1121. begin
  1122. target_def:=target_element;
  1123. caller_def:=caller_element;
  1124. target_key:=generic_param_hash(target_def);
  1125. end
  1126. { handle generic procvars }
  1127. else if (caller_def.typ=procvardef) and
  1128. (target_def.typ=procvardef) and
  1129. tprocvardef(target_def).is_specialization and
  1130. handle_procvars(genericparams,callerparams,target_def,caller_def) then
  1131. begin
  1132. continue;
  1133. end
  1134. { handle specialized objects by taking the base class as the type to specialize }
  1135. else if is_class_or_object(caller_def) and
  1136. is_class_or_object(target_def) and
  1137. genericdef.is_generic_param(target_def) then
  1138. begin
  1139. target_key:=generic_param_hash(target_def);
  1140. target_def:=tobjectdef(target_def).childof;
  1141. end
  1142. { handle generic specializations }
  1143. else if tstoreddef(target_def).is_specialization and
  1144. maybe_inherited_specialization(tstoreddef(caller_def),tstoreddef(target_def),base_def) then
  1145. begin
  1146. handle_specializations(genericparams,tstoreddef(target_def),base_def);
  1147. continue;
  1148. end
  1149. { handle all other generic params }
  1150. else if target_def.typ=undefineddef then
  1151. target_key:=generic_param_hash(target_def);
  1152. { the param doesn't have a generic key which means we don't need to consider it }
  1153. if target_key='' then
  1154. continue;
  1155. { the generic param is already used }
  1156. index:=genericparams.findindexof(target_key);
  1157. if index>=0 then
  1158. continue;
  1159. { the caller type may not have a typesym so we need to create an unnamed one }
  1160. if not assigned(caller_def.typesym) then
  1161. begin
  1162. sym:=create_unnamed_typesym(caller_def);
  1163. { add the unnamed sym to the list but only it was allocated manually }
  1164. if sym.owner=caller_def.owner then
  1165. TFPList.AddOnDemand(unnamed_syms,sym);
  1166. genericparams.add(target_key,sym);
  1167. end
  1168. else
  1169. genericparams.add(target_key,caller_def.typesym);
  1170. end;
  1171. { if the parameter counts match then the specialization is possible }
  1172. result:=genericparams.count=genericdef.genericparas.count;
  1173. { cleanup }
  1174. paras.free;
  1175. paras := nil;
  1176. if not result then begin
  1177. genericparams.free;
  1178. genericparams := nil;
  1179. end;
  1180. end;
  1181. { make an ordered list of parameters from the caller }
  1182. function make_param_list(dummysym:tsym;para:tnode;var unnamed_syms:tfplist):tfplist;
  1183. var
  1184. pt : tcallparanode;
  1185. paradef : tdef;
  1186. sym : tsym;
  1187. i : integer;
  1188. begin
  1189. result:=tfplist.create;
  1190. pt:=tcallparanode(para);
  1191. while assigned(pt) do
  1192. begin
  1193. paradef:=pt.paravalue.resultdef;
  1194. { unnamed parameter types can not be specialized }
  1195. if not assigned(paradef.typesym) then
  1196. begin
  1197. sym:=create_unnamed_typesym(paradef);
  1198. result.insert(0,sym);
  1199. { add the unnamed sym to the list but only if it was allocated manually }
  1200. if sym.owner=paradef.owner then
  1201. TFPList.AddOnDemand(unnamed_syms,sym);
  1202. end
  1203. else
  1204. result.insert(0,paradef.typesym);
  1205. pt:=tcallparanode(pt.nextpara);
  1206. end;
  1207. end;
  1208. var
  1209. i,j,k : integer;
  1210. srsym : tprocsym;
  1211. callerparams : tfplist;
  1212. pd : tprocdef;
  1213. dummysym : tprocsym;
  1214. genericparams : tfphashlist;
  1215. spezcontext : tspecializationcontext;
  1216. pd_unnamed_syms : tfplist;
  1217. begin
  1218. result:=false;
  1219. spezcontext:=nil;
  1220. genericparams:=nil;
  1221. dummysym:=tprocsym(sym);
  1222. callerparams:=make_param_list(dummysym,para,unnamed_syms);
  1223. { failed to build the parameter list }
  1224. if not assigned(callerparams) then
  1225. exit;
  1226. for i:=0 to dummysym.genprocsymovlds.count-1 do
  1227. begin
  1228. srsym:=tprocsym(dummysym.genprocsymovlds[i]);
  1229. for j:=0 to srsym.ProcdefList.Count-1 do
  1230. begin
  1231. pd:=tprocdef(srsym.ProcdefList[j]);
  1232. if is_possible_specialization(callerparams,pd,pd_unnamed_syms,genericparams) then
  1233. begin
  1234. generate_implicit_specialization(spezcontext,pd,genericparams);
  1235. genericparams.free;
  1236. genericparams := nil;
  1237. { finalize the specialization so it can be added to the list of overloads }
  1238. if not finalize_specialization(pd,spezcontext) then
  1239. begin
  1240. spezcontext.free;
  1241. spezcontext := nil;
  1242. continue;
  1243. end;
  1244. { handle unnamed syms used by the specialization }
  1245. if pd_unnamed_syms<>nil then
  1246. begin
  1247. transfer_unnamed_symbols(pd.owner,pd_unnamed_syms);
  1248. pd_unnamed_syms.free;
  1249. pd_unnamed_syms := nil;
  1250. end;
  1251. pdoverloadlist.add(pd);
  1252. spezcontext.free;
  1253. spezcontext := nil;
  1254. if po_overload in pd.procoptions then
  1255. hasoverload:=true;
  1256. { store first procsym found }
  1257. if not assigned(first_procsym) then
  1258. first_procsym:=srsym;
  1259. result:=true;
  1260. end
  1261. else
  1262. begin
  1263. { the specialization was not chosen so clean up any unnamed syms }
  1264. TFPList.FreeAndNilObjects(pd_unnamed_syms);
  1265. end;
  1266. end;
  1267. end;
  1268. { unlink unused defs }
  1269. if not(result) and assigned(callerparams) then
  1270. begin
  1271. for k:=0 to callerparams.count-1 do
  1272. begin
  1273. if (tsym(callerparams[k]).typ=typesym) and (sp_generic_unnamed_type in ttypesym(callerparams[k]).symoptions) then
  1274. ttypesym(callerparams[k]).typedef.typesym:=nil;
  1275. end;
  1276. end;
  1277. callerparams.free;
  1278. callerparams := nil;
  1279. end;
  1280. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean):tdef;
  1281. var
  1282. dummypos : tfileposinfo;
  1283. {$push}
  1284. {$warn 5036 off}
  1285. begin
  1286. result:=generate_specialization_phase1(context,genericdef,enforce_unit,nil,'',nil,dummypos);
  1287. end;
  1288. {$pop}
  1289. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;const symname:string;symtable:tsymtable):tdef;
  1290. var
  1291. dummypos : tfileposinfo;
  1292. {$push}
  1293. {$warn 5036 off}
  1294. begin
  1295. result:=generate_specialization_phase1(context,genericdef,enforce_unit,nil,symname,symtable,dummypos);
  1296. end;
  1297. {$pop}
  1298. function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef;
  1299. var
  1300. found,
  1301. err : boolean;
  1302. i,
  1303. gencount : longint;
  1304. countstr,genname,ugenname,prettygenname: string;
  1305. tmpstack : tfpobjectlist;
  1306. symowner : tsymtable;
  1307. hmodule : tmodule;
  1308. begin
  1309. context:=nil;
  1310. result:=nil;
  1311. { either symname must be given or genericdef needs to be valid }
  1312. if (symname='') and
  1313. (not assigned(genericdef) or
  1314. (
  1315. (genericdef.typ<>procdef) and
  1316. (
  1317. not assigned(genericdef.typesym) or
  1318. (genericdef.typesym.typ<>typesym)
  1319. ) and
  1320. (
  1321. (genericdef.typ<>objectdef) or
  1322. not (oo_is_forward in tobjectdef(genericdef).objectoptions)
  1323. )
  1324. ) or
  1325. (
  1326. (genericdef.typ=procdef) and
  1327. (
  1328. not assigned(tprocdef(genericdef).procsym) or
  1329. (tprocdef(genericdef).procsym.typ<>procsym)
  1330. )
  1331. )
  1332. ) then
  1333. begin
  1334. internalerror(2019112401);
  1335. end;
  1336. if not assigned(parsedtype) and not try_to_consume(_LT) then
  1337. begin
  1338. consume(_LSHARPBRACKET);
  1339. { handle "<>" }
  1340. if (token=_GT) or (token=_RSHARPBRACKET) then
  1341. begin
  1342. Message(type_e_type_id_expected);
  1343. if not try_to_consume(_GT) then
  1344. try_to_consume(_RSHARPBRACKET);
  1345. result:=generrordef;
  1346. exit;
  1347. end;
  1348. end;
  1349. context:=tspecializationcontext.create;
  1350. { Parse type parameters }
  1351. err:=not parse_generic_specialization_types_internal(context.paramlist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos);
  1352. if err then
  1353. begin
  1354. if not try_to_consume(_GT) then
  1355. try_to_consume(_RSHARPBRACKET);
  1356. context.free;
  1357. context:=nil;
  1358. result:=generrordef;
  1359. exit;
  1360. end;
  1361. { use the name of the symbol as procvars return a user friendly version
  1362. of the name }
  1363. if symname='' then
  1364. begin
  1365. if genericdef.typ=procdef then
  1366. genname:=tprocdef(genericdef).procsym.realname
  1367. else if assigned(genericdef.typesym) then
  1368. genname:=ttypesym(genericdef.typesym).realname
  1369. else if (genericdef.typ=objectdef) and (oo_is_forward in tobjectdef(genericdef).objectoptions) then
  1370. genname:=tobjectdef(genericdef).objrealname^
  1371. else
  1372. internalerror(2020071201);
  1373. end
  1374. else
  1375. genname:=symname;
  1376. { in case of non-Delphi mode the type name could already be a generic
  1377. def (but maybe the wrong one) }
  1378. if assigned(genericdef) and
  1379. ([df_generic,df_specialization]*genericdef.defoptions<>[]) then
  1380. begin
  1381. { remove the type count suffix from the generic's name }
  1382. for i:=Length(genname) downto 1 do
  1383. if genname[i]='$' then
  1384. begin
  1385. genname:=copy(genname,1,i-1);
  1386. break;
  1387. end;
  1388. { in case of a specialization we've only reached the specialization
  1389. checksum yet }
  1390. if df_specialization in genericdef.defoptions then
  1391. for i:=length(genname) downto 1 do
  1392. if genname[i]='$' then
  1393. begin
  1394. genname:=copy(genname,1,i-1);
  1395. break;
  1396. end;
  1397. end
  1398. else
  1399. begin
  1400. split_generic_name(genname,ugenname,gencount);
  1401. if genname<>ugenname then
  1402. genname:=ugenname;
  1403. end;
  1404. { search a generic with the given count of params }
  1405. countstr:='';
  1406. str(context.paramlist.Count,countstr);
  1407. prettygenname:=genname;
  1408. genname:=genname+'$'+countstr;
  1409. ugenname:=upper(genname);
  1410. context.genname:=genname;
  1411. if assigned(genericdef) then
  1412. symowner:=genericdef.owner
  1413. else
  1414. symowner:=symtable;
  1415. if assigned(symowner) and (symowner.symtabletype in [objectsymtable,recordsymtable]) then
  1416. begin
  1417. if symowner.symtabletype = objectsymtable then
  1418. found:=searchsym_in_class(tobjectdef(symowner.defowner),tobjectdef(symowner.defowner),ugenname,context.sym,context.symtable,[])
  1419. else
  1420. found:=searchsym_in_record(tabstractrecorddef(symowner.defowner),ugenname,context.sym,context.symtable);
  1421. if not found then
  1422. found:=searchsym(ugenname,context.sym,context.symtable);
  1423. end
  1424. else if enforce_unit then
  1425. begin
  1426. if not assigned(symowner) then
  1427. internalerror(2022102101);
  1428. if not (symowner.symtabletype in [globalsymtable,staticsymtable]) then
  1429. internalerror(2022102102);
  1430. hmodule:=find_module_from_symtable(symowner);
  1431. if not assigned(hmodule) then
  1432. internalerror(2022102103);
  1433. found:=searchsym_in_module(hmodule,ugenname,context.sym,context.symtable);
  1434. end
  1435. else
  1436. found:=searchsym(ugenname,context.sym,context.symtable);
  1437. if found and (context.sym.typ=absolutevarsym) and
  1438. (vo_is_funcret in tabstractvarsym(context.sym).varoptions) then
  1439. begin
  1440. { we found the function result alias of a generic function; go up the
  1441. symbol stack *before* this alias was inserted, so that we can
  1442. (hopefully) find the correct generic symbol }
  1443. tmpstack:=tfpobjectlist.create(false);
  1444. while assigned(symtablestack.top) do
  1445. begin
  1446. tmpstack.Add(symtablestack.top);
  1447. symtablestack.pop(symtablestack.top);
  1448. if tmpstack.Last=context.symtable then
  1449. break;
  1450. end;
  1451. if not assigned(symtablestack.top) then
  1452. internalerror(2019123001);
  1453. found:=searchsym(ugenname,context.sym,context.symtable);
  1454. for i:=tmpstack.count-1 downto 0 do
  1455. symtablestack.push(tsymtable(tmpstack[i]));
  1456. tmpstack.free;
  1457. tmpstack := nil;
  1458. end;
  1459. if not found or not (context.sym.typ in [typesym,procsym]) then
  1460. begin
  1461. identifier_not_found(prettygenname);
  1462. if not try_to_consume(_GT) then
  1463. try_to_consume(_RSHARPBRACKET);
  1464. context.free;
  1465. context:=nil;
  1466. result:=generrordef;
  1467. exit;
  1468. end;
  1469. { we've found the correct def }
  1470. if context.sym.typ=typesym then
  1471. result:=tstoreddef(ttypesym(context.sym).typedef)
  1472. else
  1473. begin
  1474. if tprocsym(context.sym).procdeflist.count=0 then
  1475. internalerror(2015061203);
  1476. result:=tstoreddef(tprocsym(context.sym).procdefList[0]);
  1477. end;
  1478. if not try_to_consume(_GT) then
  1479. consume(_RSHARPBRACKET);
  1480. end;
  1481. function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;const _prettyname:ansistring):tdef;
  1482. procedure unset_forwarddef(def: tdef);
  1483. var
  1484. st : TSymtable;
  1485. i : longint;
  1486. begin
  1487. case def.typ of
  1488. procdef:
  1489. tprocdef(def).forwarddef:=false;
  1490. objectdef,
  1491. recorddef:
  1492. begin
  1493. st:=def.getsymtable(gs_record);
  1494. for i:=0 to st.deflist.count-1 do
  1495. unset_forwarddef(tdef(st.deflist[i]));
  1496. end;
  1497. else
  1498. ;
  1499. end;
  1500. end;
  1501. procedure retrieve_genericdef_or_procsym(sym:tsym;out gendef:tdef;out psym:tsym);
  1502. var
  1503. i : longint;
  1504. begin
  1505. gendef:=nil;
  1506. psym:=nil;
  1507. case sym.typ of
  1508. typesym:
  1509. begin
  1510. gendef:=ttypesym(sym).typedef
  1511. end;
  1512. procsym:
  1513. begin
  1514. for i:=0 to tprocsym(sym).procdeflist.count-1 do
  1515. if tstoreddef(tprocsym(sym).procdeflist[i]).genericdef=genericdef then
  1516. begin
  1517. gendef:=tdef(tprocsym(sym).procdeflist[i]);
  1518. break;
  1519. end;
  1520. psym:=sym;
  1521. end
  1522. else
  1523. internalerror(200710171);
  1524. end;
  1525. end;
  1526. function find_in_hierarchy(def:tdef;generictypelist:tfphashobjectlist):tdef;
  1527. var
  1528. paramdef1,
  1529. paramdef2 : tdef;
  1530. allequal : boolean;
  1531. i : longint;
  1532. begin
  1533. result:=nil;
  1534. while assigned(def) do
  1535. begin
  1536. if (df_generic in def.defoptions) and (def=genericdef) then
  1537. begin
  1538. result:=def;
  1539. break;
  1540. end;
  1541. { the following happens when a routine with its parent struct
  1542. as parameter is specialized as a parameter or result of a
  1543. generic function }
  1544. if (df_specialization in def.defoptions) and (tstoreddef(def).genericdef=genericdef) then
  1545. begin
  1546. if tstoreddef(def).genericparas.count=generictypelist.count then
  1547. begin
  1548. allequal:=true;
  1549. for i:=0 to generictypelist.count-1 do
  1550. begin
  1551. if tsym(generictypelist[i]).typ<>tsym(tstoreddef(def).genericparas[i]).typ then
  1552. begin
  1553. allequal:=false;
  1554. break;
  1555. end;
  1556. if tsym(generictypelist[i]).typ=constsym then
  1557. paramdef1:=tconstsym(generictypelist[i]).constdef
  1558. else
  1559. paramdef1:=ttypesym(generictypelist[i]).typedef;
  1560. if tsym(tstoreddef(def).genericparas[i]).typ=constsym then
  1561. paramdef2:=tconstsym(tstoreddef(def).genericparas[i]).constdef
  1562. else
  1563. paramdef2:=ttypesym(tstoreddef(def).genericparas[i]).typedef;
  1564. if not equal_defs(paramdef1,paramdef2) then
  1565. begin
  1566. allequal:=false;
  1567. break;
  1568. end;
  1569. if (tsym(generictypelist[i]).typ=constsym) and
  1570. (
  1571. (tconstsym(generictypelist[i]).consttyp<>tconstsym(tstoreddef(def).genericparas[i]).consttyp) or
  1572. not same_constvalue(tconstsym(generictypelist[i]).consttyp,tconstsym(generictypelist[i]).value,tconstsym(tstoreddef(def).genericparas[i]).value)
  1573. ) then
  1574. begin
  1575. allequal:=false;
  1576. break;
  1577. end;
  1578. end;
  1579. if allequal then
  1580. begin
  1581. result:=def;
  1582. break;
  1583. end;
  1584. end;
  1585. end;
  1586. if assigned(def.owner) then
  1587. def:=tstoreddef(def.owner.defowner)
  1588. else
  1589. def:=nil;
  1590. end;
  1591. end;
  1592. function has_generic_paras(adef: tstoreddef): boolean;
  1593. var
  1594. i: Integer;
  1595. begin
  1596. result:=False;
  1597. if adef.genericparas<>nil then
  1598. for i:=0 to adef.genericparas.Count-1 do
  1599. if ((tsym(adef.genericparas[i]).typ=typesym) and (sp_generic_para in tsym(adef.genericparas[i]).symoptions)) or
  1600. ((tsym(adef.genericparas[i]).typ=constsym) and not (sp_generic_const in tsym(adef.genericparas[i]).symoptions)) then
  1601. exit(true);
  1602. end;
  1603. var
  1604. finalspecializename,
  1605. ufinalspecializename : tidstring;
  1606. hierarchy,
  1607. prettyname : ansistring;
  1608. generictypelist : tfphashobjectlist;
  1609. srsymtable,
  1610. specializest : tsymtable;
  1611. hashedid : thashedidstring;
  1612. tempst : tglobalsymtable;
  1613. tsrsym : ttypesym;
  1614. psym,
  1615. srsym : tsym;
  1616. flags : thccflags;
  1617. paramdef1,
  1618. paramdef2,
  1619. def : tdef;
  1620. old_block_type : tblock_type;
  1621. state : tspecializationstate;
  1622. old_current_structdef : tabstractrecorddef;
  1623. old_current_specializedef,
  1624. old_current_genericdef : tstoreddef;
  1625. old_current_procinfo : tprocinfo;
  1626. old_module_procinfo : tobject;
  1627. hmodule : tmodule;
  1628. oldcurrent_filepos : tfileposinfo;
  1629. recordbuf : tdynamicarray;
  1630. hadtypetoken : boolean;
  1631. i,
  1632. replaydepth : longint;
  1633. item : tobject;
  1634. allequal,
  1635. hintsprocessed : boolean;
  1636. pd : tprocdef;
  1637. pdflags : tpdflags;
  1638. ppflags : tparse_proc_flags;
  1639. begin
  1640. if not assigned(context) then
  1641. internalerror(2015052203);
  1642. result:=nil;
  1643. pd:=nil;
  1644. hmodule:=nil;
  1645. if not check_generic_constraints(genericdef,context.paramlist,context.poslist) then
  1646. begin
  1647. { the parameters didn't fit the constraints, so don't continue with the
  1648. specialization }
  1649. result:=generrordef;
  1650. exit;
  1651. end;
  1652. { build the new type's name }
  1653. hierarchy:=genericdef.ownerhierarchyname;
  1654. if assigned(genericdef.owner) then
  1655. begin
  1656. hmodule:=find_module_from_symtable(genericdef.owner);
  1657. if not assigned(hmodule) then
  1658. internalerror(2022102801);
  1659. if hierarchy<>'' then
  1660. hierarchy:='.'+hierarchy;
  1661. hierarchy:=hmodule.modulename^+hierarchy;
  1662. end;
  1663. finalspecializename:=generate_generic_name(context.genname,context.specializename,hierarchy);
  1664. ufinalspecializename:=upper(finalspecializename);
  1665. if genericdef.typ=procdef then
  1666. prettyname:=tprocdef(genericdef).procsym.prettyname
  1667. else
  1668. prettyname:=genericdef.typesym.prettyname;
  1669. prettyname:=prettyname+'<'+context.prettyname+'>';
  1670. generictypelist:=tfphashobjectlist.create(false);
  1671. { build the list containing the types for the generic params }
  1672. if not assigned(genericdef.genericparas) then
  1673. internalerror(2013092601);
  1674. if context.paramlist.count<>genericdef.genericparas.count then
  1675. internalerror(2013092603);
  1676. for i:=0 to genericdef.genericparas.Count-1 do
  1677. begin
  1678. srsym:=tsym(genericdef.genericparas[i]);
  1679. if not (sp_generic_para in srsym.symoptions) then
  1680. internalerror(2013092602);
  1681. generictypelist.add(srsym.realname,context.paramlist[i]);
  1682. end;
  1683. { Special case if we are referencing the current defined object }
  1684. if assigned(current_structdef) and
  1685. (current_structdef.objname^=ufinalspecializename) then
  1686. result:=current_structdef;
  1687. { Can we reuse an already specialized type? }
  1688. { for this first check whether we are currently specializing a nested
  1689. type of the current (main) specialization (this is necessary, because
  1690. during that time the symbol of the main specialization will still
  1691. contain a reference to an errordef) }
  1692. if not assigned(result) and assigned(current_specializedef) then
  1693. begin
  1694. def:=current_specializedef;
  1695. repeat
  1696. if def.typ in [objectdef,recorddef] then
  1697. if tabstractrecorddef(def).objname^=ufinalspecializename then begin
  1698. result:=def;
  1699. break;
  1700. end;
  1701. if assigned(def.owner) then
  1702. def:=tstoreddef(def.owner.defowner)
  1703. else
  1704. { this can happen when specializing a generic function }
  1705. def:=nil;
  1706. until not assigned(def) or not (df_specialization in def.defoptions);
  1707. end;
  1708. { if the genericdef is the def we are currently parsing (or one of its parents) then we can
  1709. not use it for specializing as the tokenbuffer is not yet set (and we aren't done with
  1710. parsing anyway), so for now we treat those still as generic defs without doing a partial
  1711. specialization }
  1712. if not assigned(result) then
  1713. begin
  1714. def:=current_genericdef;
  1715. if def=genericdef then
  1716. result:=def
  1717. else if assigned(current_genericdef) then
  1718. result:=find_in_hierarchy(current_genericdef,generictypelist);
  1719. if not assigned(result) and assigned(current_specializedef) then
  1720. result:=find_in_hierarchy(current_specializedef,generictypelist);
  1721. end;
  1722. { decide in which symtable to put the specialization }
  1723. if assigned(context.forwarddef) then
  1724. begin
  1725. specializest:=context.forwarddef.owner;
  1726. end
  1727. else if parse_generic and not assigned(result) then
  1728. begin
  1729. srsymtable:=symtablestack.top;
  1730. if (srsymtable.symtabletype in [localsymtable,parasymtable]) and tstoreddef(srsymtable.defowner).is_specialization then
  1731. { if we are currently specializing a routine we need to specialize into
  1732. the routine's local- or parasymtable so that they are correctly
  1733. registered should the specialization be finalized }
  1734. specializest:=srsymtable
  1735. else if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then
  1736. { if we are parsing the definition of a method we specialize into
  1737. the local symtable of it }
  1738. specializest:=current_procinfo.procdef.getsymtable(gs_local)
  1739. else
  1740. begin
  1741. if not assigned(current_genericdef) then
  1742. internalerror(2014050901);
  1743. { we specialize the partial specialization into the symtable of the currently parsed
  1744. generic }
  1745. case current_genericdef.typ of
  1746. procvardef:
  1747. specializest:=current_genericdef.getsymtable(gs_para);
  1748. procdef:
  1749. specializest:=current_genericdef.getsymtable(gs_local);
  1750. objectdef,
  1751. recorddef:
  1752. specializest:=current_genericdef.getsymtable(gs_record);
  1753. arraydef:
  1754. specializest:=tarraydef(current_genericdef).symtable;
  1755. else
  1756. internalerror(2014050902);
  1757. end;
  1758. end;
  1759. end
  1760. else
  1761. begin
  1762. { if one of the type parameters is owned by a local- or parasymtable
  1763. then use the localsymtable for specialization }
  1764. specializest:=nil;
  1765. for i:=0 to context.paramlist.count-1 do
  1766. begin
  1767. psym:=tsym(context.paramlist[i]);
  1768. if psym.owner.symtabletype in [localsymtable,parasymtable] then
  1769. begin
  1770. if (psym.owner.symtabletype=localsymtable) or (psym.owner.defowner.typ<>procdef) then
  1771. specializest:=psym.owner
  1772. else
  1773. specializest:=tprocdef(psym.owner.defowner).getsymtable(gs_local);
  1774. if not assigned(specializest) then
  1775. internalerror(2025122402);
  1776. break;
  1777. end;
  1778. end;
  1779. if not assigned(specializest) then
  1780. if current_module.is_unit and current_module.in_interface then
  1781. specializest:=current_module.globalsymtable
  1782. else
  1783. specializest:=current_module.localsymtable;
  1784. end;
  1785. if not assigned(specializest) then
  1786. internalerror(2014050910);
  1787. { now check whether there is a specialization somewhere else }
  1788. psym:=nil;
  1789. if not assigned(result) then
  1790. begin
  1791. hashedid.id:=ufinalspecializename;
  1792. if (specializest.symtabletype=objectsymtable) and not assigned(context.forwarddef) then
  1793. begin
  1794. { search also in parent classes }
  1795. if not assigned(current_genericdef) or (current_genericdef.typ<>objectdef) then
  1796. internalerror(2016112901);
  1797. if not searchsym_in_class(tobjectdef(current_genericdef),tobjectdef(current_genericdef),ufinalspecializename,srsym,srsymtable,[]) then
  1798. srsym:=nil;
  1799. end
  1800. else
  1801. srsym:=tsym(specializest.findwithhash(hashedid));
  1802. if assigned(context.forwarddef) then
  1803. begin
  1804. { just do a few sanity checks }
  1805. if not assigned(srsym) or not (srsym.typ=typesym) then
  1806. internalerror(2020070306);
  1807. if ttypesym(srsym).typedef<>context.forwarddef then
  1808. internalerror(2020070307);
  1809. end
  1810. else if assigned(srsym) then
  1811. begin
  1812. retrieve_genericdef_or_procsym(srsym,result,psym);
  1813. end
  1814. else
  1815. { the generic could have been specialized in the globalsymtable
  1816. already, so search there as well }
  1817. if (specializest<>current_module.globalsymtable) and assigned(current_module.globalsymtable) then
  1818. begin
  1819. srsym:=tsym(current_module.globalsymtable.findwithhash(hashedid));
  1820. if assigned(srsym) then
  1821. begin
  1822. retrieve_genericdef_or_procsym(srsym,result,psym);
  1823. end;
  1824. end;
  1825. end;
  1826. if not assigned(result) then
  1827. begin
  1828. specialization_init(genericdef,state);
  1829. { push a temporary global symtable so that the specialization is
  1830. added to the correct symtable; this symtable does not contain
  1831. any other symbols, so that the type resolution can not be
  1832. influenced by symbols in the current unit }
  1833. tempst:=tspecializesymtable.create(current_module.modulename^,current_module.moduleid);
  1834. symtablestack.push(tempst);
  1835. { Reparse the original type definition }
  1836. begin
  1837. old_current_specializedef:=nil;
  1838. old_current_genericdef:=nil;
  1839. old_current_structdef:=nil;
  1840. old_current_procinfo:=current_procinfo;
  1841. old_module_procinfo:=current_module.procinfo;
  1842. current_procinfo:=nil;
  1843. current_module.procinfo:=nil;
  1844. if parse_class_parent then
  1845. begin
  1846. old_current_structdef:=current_structdef;
  1847. old_current_genericdef:=current_genericdef;
  1848. old_current_specializedef:=current_specializedef;
  1849. if genericdef.owner.symtabletype in [recordsymtable,objectsymtable] then
  1850. current_structdef:=tabstractrecorddef(genericdef.owner.defowner)
  1851. else
  1852. current_structdef:=nil;
  1853. current_genericdef:=nil;
  1854. current_specializedef:=nil;
  1855. end;
  1856. maybe_add_waiting_unit(genericdef);
  1857. { First a new sym so we can reuse this specialization and
  1858. references to this specialization can be handled }
  1859. if genericdef.typ=procdef then
  1860. if assigned(psym) then
  1861. srsym:=psym
  1862. else
  1863. srsym:=cprocsym.create(finalspecializename)
  1864. else
  1865. srsym:=ctypesym.create(finalspecializename,generrordef);
  1866. { insert the symbol only if we don't know already that we have
  1867. a procsym to add it to and we aren't dealing with a forwarddef }
  1868. if not assigned(psym) and not assigned(context.forwarddef) then
  1869. specializest.insertsym(srsym);
  1870. { specializations are declarations as such it is the wisest to
  1871. declare set the blocktype to "type"; otherwise we'll
  1872. experience unexpected side effects like the addition of
  1873. classrefdefs if we have a generic that's derived from another
  1874. generic }
  1875. old_block_type:=block_type;
  1876. block_type:=bt_type;
  1877. if (
  1878. (genericdef.typ=procdef) and
  1879. not assigned(tprocdef(genericdef).genericdecltokenbuf)
  1880. ) or (
  1881. (genericdef.typ<>procdef) and
  1882. not assigned(genericdef.generictokenbuf)
  1883. ) then
  1884. internalerror(200511171);
  1885. if hmodule=nil then
  1886. internalerror(2012051202);
  1887. oldcurrent_filepos:=current_filepos;
  1888. { use the index the module got from the current compilation process }
  1889. current_filepos.moduleindex:=hmodule.unit_index;
  1890. current_tokenpos:=current_filepos;
  1891. if parse_generic then
  1892. begin
  1893. recordbuf:=current_scanner.recordtokenbuf;
  1894. current_scanner.recordtokenbuf:=nil;
  1895. end
  1896. else
  1897. recordbuf:=nil;
  1898. replaydepth:=current_scanner.replay_stack_depth;
  1899. if genericdef.typ=procdef then
  1900. begin
  1901. current_scanner.startreplaytokens(tprocdef(genericdef).genericdecltokenbuf,hmodule.change_endian);
  1902. parse_proc_head(tprocdef(genericdef).struct,tprocdef(genericdef).proctypeoption,[],genericdef,generictypelist,pd);
  1903. if assigned(pd) then
  1904. begin
  1905. if assigned(psym) then
  1906. pd.procsym:=psym
  1907. else
  1908. pd.procsym:=srsym;
  1909. ppflags:=[];
  1910. if po_classmethod in tprocdef(genericdef).procoptions then
  1911. include(ppflags,ppf_classmethod);
  1912. parse_proc_dec_finish(pd,ppflags,tprocdef(genericdef).struct);
  1913. end;
  1914. result:=pd;
  1915. end
  1916. else
  1917. begin
  1918. current_scanner.startreplaytokens(genericdef.generictokenbuf,hmodule.change_endian);
  1919. if assigned(context.forwarddef) then
  1920. begin
  1921. tsrsym:=nil;
  1922. result:=parse_forward_declaration(context.forwarddef.typesym,ufinalspecializename,finalspecializename,genericdef,generictypelist,tsrsym);
  1923. srsym:=tsrsym;
  1924. end
  1925. else
  1926. begin
  1927. hadtypetoken:=false;
  1928. { ensure a pretty name for error messages, might be chanced below }
  1929. if _prettyname<>'' then
  1930. ttypesym(srsym).fprettyname:=_prettyname
  1931. else
  1932. ttypesym(srsym).fprettyname:=prettyname;
  1933. read_named_type(result,srsym,genericdef,generictypelist,false,hadtypetoken);
  1934. ttypesym(srsym).typedef:=result;
  1935. result.typesym:=srsym;
  1936. end;
  1937. if _prettyname<>'' then
  1938. ttypesym(result.typesym).fprettyname:=_prettyname
  1939. else
  1940. ttypesym(result.typesym).fprettyname:=prettyname;
  1941. end;
  1942. current_filepos:=oldcurrent_filepos;
  1943. { Note regarding hint directives:
  1944. There is no need to remove the flags for them from the
  1945. specialized generic symbol, because hint directives that
  1946. follow the specialization are handled by the code in
  1947. pdecl.types_dec and added to the type symbol.
  1948. E.g.: TFoo = TBar<Blubb> deprecated;
  1949. Here the symbol TBar$1$Blubb will contain the
  1950. "sp_hint_deprecated" flag while the TFoo symbol won't.}
  1951. case result.typ of
  1952. { Build VMT indexes for classes and read hint directives }
  1953. objectdef:
  1954. begin
  1955. if replaydepth<current_scanner.replay_stack_depth then
  1956. begin
  1957. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  1958. if replaydepth<current_scanner.replay_stack_depth then
  1959. consume(_SEMICOLON);
  1960. end;
  1961. if oo_is_forward in tobjectdef(result).objectoptions then
  1962. add_forward_generic_def(result,context)
  1963. else if not (oo_inherits_not_specialized in tobjectdef(result).objectoptions) then
  1964. build_vmt(tobjectdef(result))
  1965. else
  1966. { update the procdevs to add hidden self param }
  1967. insert_struct_hidden_paras(tobjectdef(result));
  1968. end;
  1969. { handle params, calling convention, etc }
  1970. procvardef:
  1971. begin
  1972. hintsprocessed:=false;
  1973. if replaydepth<current_scanner.replay_stack_depth then
  1974. begin
  1975. if not check_proc_directive(true) then
  1976. begin
  1977. hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  1978. if replaydepth<current_scanner.replay_stack_depth then
  1979. consume(_SEMICOLON);
  1980. end
  1981. else
  1982. hintsprocessed:=true;
  1983. end;
  1984. if replaydepth<current_scanner.replay_stack_depth then
  1985. parse_proctype_directives(tprocvardef(result));
  1986. if po_is_function_ref in tprocvardef(result).procoptions then
  1987. adjust_funcref(result,srsym,nil);
  1988. if result.typ=procvardef then
  1989. flags:=hcc_default_actions_intf
  1990. else
  1991. flags:=hcc_default_actions_intf_struct;
  1992. handle_calling_convention(result,flags);
  1993. if not hintsprocessed and (replaydepth<current_scanner.replay_stack_depth) then
  1994. begin
  1995. try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg);
  1996. if replaydepth<current_scanner.replay_stack_depth then
  1997. consume(_SEMICOLON);
  1998. end;
  1999. end;
  2000. procdef:
  2001. begin
  2002. pdflags:=[];
  2003. if genericdef.owner.symtabletype=objectsymtable then
  2004. include(pdflags,pd_object)
  2005. else if genericdef.owner.symtabletype=recordsymtable then
  2006. include(pdflags,pd_record);
  2007. parse_proc_directives(pd,pdflags);
  2008. while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do
  2009. consume(_SEMICOLON);
  2010. if parse_generic then
  2011. handle_calling_convention(tprocdef(result),hcc_default_actions_intf)
  2012. else
  2013. handle_calling_convention(tprocdef(result),hcc_default_actions_impl);
  2014. proc_add_definition(tprocdef(result));
  2015. { for partial specializations we implicitly declare the routine as
  2016. having its implementation although we'll not specialize it in reality }
  2017. if parse_generic then
  2018. unset_forwarddef(result);
  2019. end;
  2020. else
  2021. { parse hint directives for records and arrays }
  2022. if replaydepth<current_scanner.replay_stack_depth then begin
  2023. try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg);
  2024. if replaydepth<current_scanner.replay_stack_depth then
  2025. consume(_SEMICOLON);
  2026. end;
  2027. end;
  2028. { Consume the remainder of the buffer }
  2029. while current_scanner.replay_stack_depth>replaydepth do
  2030. consume(token);
  2031. if assigned(recordbuf) then
  2032. begin
  2033. if assigned(current_scanner.recordtokenbuf) then
  2034. internalerror(2014050909);
  2035. current_scanner.recordtokenbuf:=recordbuf;
  2036. end;
  2037. block_type:=old_block_type;
  2038. current_procinfo:=old_current_procinfo;
  2039. current_module.procinfo:=old_module_procinfo;
  2040. if parse_class_parent then
  2041. begin
  2042. current_structdef:=old_current_structdef;
  2043. current_genericdef:=old_current_genericdef;
  2044. current_specializedef:=old_current_specializedef;
  2045. end;
  2046. end;
  2047. { extract all created symbols and defs from the temporary symtable
  2048. and add them to the specializest }
  2049. for i:=tempst.SymList.Count-1 downto 0 do
  2050. begin
  2051. item:=tempst.SymList.Items[i];
  2052. { using changeowner the symbol is automatically added to the
  2053. new symtable }
  2054. tsym(item).ChangeOwner(specializest);
  2055. end;
  2056. for i:=tempst.DefList.Count-1 downto 0 do
  2057. begin
  2058. item:=tempst.DefList.Items[i];
  2059. { using changeowner the def is automatically added to the new
  2060. symtable }
  2061. tdef(item).ChangeOwner(specializest);
  2062. { for partial specializations we implicitly declare any methods as having their
  2063. implementations although we'll not specialize them in reality }
  2064. if parse_generic or has_generic_paras(tstoreddef(item)) then
  2065. unset_forwarddef(tdef(item));
  2066. end;
  2067. { if a generic was declared during the specialization we need to
  2068. flag the specialize symtable accordingly }
  2069. if sto_has_generic in tempst.tableoptions then
  2070. specializest.includeoption(sto_has_generic);
  2071. tempst.free;
  2072. tempst := nil;
  2073. specialization_done(state);
  2074. { procdefs are only added once we know which overload we use }
  2075. if not parse_generic and (result.typ<>procdef) and
  2076. not has_generic_paras(tstoreddef(result)) then
  2077. current_module.pendingspecializations.add(result.typename,result);
  2078. end;
  2079. generictypelist.free;
  2080. generictypelist := nil;
  2081. if assigned(genericdef) then
  2082. begin
  2083. { check the hints of the found generic symbol }
  2084. if genericdef.typ=procdef then
  2085. srsym:=tprocdef(genericdef).procsym
  2086. else
  2087. srsym:=genericdef.typesym;
  2088. check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
  2089. end;
  2090. end;
  2091. procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);
  2092. var
  2093. context : tspecializationcontext;
  2094. genericdef : tstoreddef;
  2095. begin
  2096. genericdef:=tstoreddef(generate_specialization_phase1(context,tt,enforce_unit,parsedtype,symname,nil,parsedpos));
  2097. if genericdef<>generrordef then
  2098. genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname));
  2099. tt:=genericdef;
  2100. if assigned(context) then
  2101. context.free; // no nil needed
  2102. end;
  2103. function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
  2104. var
  2105. generictype : tstoredsym;
  2106. i,firstidx,const_list_index : longint;
  2107. srsymtable : tsymtable;
  2108. basedef,def : tdef;
  2109. defname : tidstring;
  2110. allowconst,
  2111. allowconstructor,
  2112. is_const,
  2113. doconsume : boolean;
  2114. constraintdata : tgenericconstraintdata;
  2115. old_block_type : tblock_type;
  2116. fileinfo : tfileposinfo;
  2117. begin
  2118. result:=tfphashobjectlist.create(false);
  2119. firstidx:=0;
  2120. const_list_index:=0;
  2121. old_block_type:=block_type;
  2122. block_type:=bt_type;
  2123. allowconst:=true;
  2124. is_const:=false;
  2125. repeat
  2126. if allowconst and try_to_consume(_CONST) then
  2127. begin
  2128. allowconst:=false;
  2129. is_const:=true;
  2130. const_list_index:=result.count;
  2131. end;
  2132. if token=_ID then
  2133. begin
  2134. if is_const then
  2135. generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype)
  2136. else
  2137. generictype:=ctypesym.create(orgpattern,cundefinedtype);
  2138. { type parameters need to be added as strict private }
  2139. generictype.visibility:=vis_strictprivate;
  2140. include(generictype.symoptions,sp_generic_para);
  2141. result.add(orgpattern,generictype);
  2142. end;
  2143. consume(_ID);
  2144. fileinfo:=current_tokenpos;
  2145. { const restriction }
  2146. if is_const and try_to_consume(_COLON) then
  2147. begin
  2148. def:=nil;
  2149. { parse the type and assign the const type to generictype }
  2150. single_type(def,[]);
  2151. for i:=const_list_index to result.count-1 do
  2152. begin
  2153. { finalize constant information once type is known }
  2154. if assigned(def) and (def.typ in tgeneric_param_const_types) then
  2155. begin
  2156. case def.typ of
  2157. orddef,
  2158. enumdef:
  2159. tconstsym(result[i]).consttyp:=constord;
  2160. stringdef:
  2161. tconstsym(result[i]).consttyp:=conststring;
  2162. floatdef:
  2163. tconstsym(result[i]).consttyp:=constreal;
  2164. setdef:
  2165. tconstsym(result[i]).consttyp:=constset;
  2166. { pointer always refers to nil with constants }
  2167. pointerdef:
  2168. tconstsym(result[i]).consttyp:=constnil;
  2169. else
  2170. internalerror(2020011402);
  2171. end;
  2172. tconstsym(result[i]).constdef:=def;
  2173. end
  2174. else
  2175. Message1(type_e_generic_const_type_not_allowed,def.fulltypename);
  2176. end;
  2177. { after type restriction const list terminates }
  2178. is_const:=false;
  2179. end
  2180. { type restriction }
  2181. else if try_to_consume(_COLON) then
  2182. begin
  2183. if not allowconstraints then
  2184. Message(parser_e_generic_constraints_not_allowed_here);
  2185. { construct a name which can be used for a type specification }
  2186. constraintdata:=tgenericconstraintdata.create;
  2187. constraintdata.fileinfo:=fileinfo;
  2188. defname:='';
  2189. str(current_module.deflist.count,defname);
  2190. defname:='$gendef'+defname;
  2191. allowconstructor:=m_delphi in current_settings.modeswitches;
  2192. basedef:=generrordef;
  2193. repeat
  2194. doconsume:=true;
  2195. case token of
  2196. _CONSTRUCTOR:
  2197. begin
  2198. if not allowconstructor or (gcf_constructor in constraintdata.flags) then
  2199. Message(parser_e_illegal_expression);
  2200. include(constraintdata.flags,gcf_constructor);
  2201. allowconstructor:=false;
  2202. end;
  2203. _CLASS:
  2204. begin
  2205. if gcf_class in constraintdata.flags then
  2206. Message(parser_e_illegal_expression);
  2207. if basedef=generrordef then
  2208. include(constraintdata.flags,gcf_class)
  2209. else
  2210. Message(parser_e_illegal_expression);
  2211. end;
  2212. _RECORD:
  2213. begin
  2214. if ([gcf_constructor,gcf_class]*constraintdata.flags<>[])
  2215. or (constraintdata.interfaces.count>0) then
  2216. Message(parser_e_illegal_expression)
  2217. else
  2218. begin
  2219. srsymtable:=trecordsymtable.create(defname,0,1);
  2220. basedef:=crecorddef.create(defname,srsymtable);
  2221. include(constraintdata.flags,gcf_record);
  2222. allowconstructor:=false;
  2223. end;
  2224. end;
  2225. else
  2226. begin
  2227. { after single_type "token" is the trailing ",", ";" or
  2228. ">"! }
  2229. doconsume:=false;
  2230. { def is already set to a class or record }
  2231. if gcf_record in constraintdata.flags then
  2232. Message(parser_e_illegal_expression);
  2233. single_type(def, [stoAllowSpecialization]);
  2234. { only types that are inheritable are allowed }
  2235. if (def.typ<>objectdef) or
  2236. not (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_javaclass]) then
  2237. Message1(type_e_class_or_interface_type_expected,def.typename)
  2238. else
  2239. case tobjectdef(def).objecttype of
  2240. odt_class,
  2241. odt_javaclass:
  2242. begin
  2243. if gcf_class in constraintdata.flags then
  2244. { "class" + concrete class is not allowed }
  2245. Message(parser_e_illegal_expression)
  2246. else
  2247. { do we already have a concrete class? }
  2248. if basedef<>generrordef then
  2249. Message(parser_e_illegal_expression)
  2250. else
  2251. basedef:=def;
  2252. end;
  2253. odt_interfacecom,
  2254. odt_interfacecorba,
  2255. odt_interfacejava,
  2256. odt_dispinterface:
  2257. constraintdata.interfaces.add(def);
  2258. else
  2259. ;
  2260. end;
  2261. end;
  2262. end;
  2263. if doconsume then
  2264. consume(token);
  2265. until not try_to_consume(_COMMA);
  2266. if ([gcf_class,gcf_constructor]*constraintdata.flags<>[]) or
  2267. (constraintdata.interfaces.count>1) or
  2268. (
  2269. (basedef.typ=objectdef) and
  2270. (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class])
  2271. ) then
  2272. begin
  2273. if basedef.typ=errordef then
  2274. { don't pass an errordef as a parent to a tobjectdef }
  2275. basedef:=class_tobject
  2276. else
  2277. if (basedef.typ<>objectdef) or
  2278. not (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class]) then
  2279. internalerror(2012101101);
  2280. basedef:=cobjectdef.create(tobjectdef(basedef).objecttype,defname,tobjectdef(basedef),false);
  2281. for i:=0 to constraintdata.interfaces.count-1 do
  2282. tobjectdef(basedef).register_implemented_interface(tobjectdef(constraintdata.interfaces[i]),false);
  2283. end
  2284. else
  2285. if constraintdata.interfaces.count=1 then
  2286. begin
  2287. if basedef.typ<>errordef then
  2288. internalerror(2013021601);
  2289. def:=tdef(constraintdata.interfaces[0]);
  2290. basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false);
  2291. constraintdata.interfaces.delete(0);
  2292. end;
  2293. if basedef.typ<>errordef then
  2294. with tstoreddef(basedef) do
  2295. begin
  2296. genconstraintdata:=tgenericconstraintdata.create;
  2297. genconstraintdata.flags:=constraintdata.flags;
  2298. genconstraintdata.interfaces.assign(constraintdata.interfaces);
  2299. genconstraintdata.fileinfo:=constraintdata.fileinfo;
  2300. include(defoptions,df_genconstraint);
  2301. end;
  2302. for i:=firstidx to result.count-1 do
  2303. ttypesym(result[i]).typedef:=basedef;
  2304. { we need a typesym in case we do a Delphi-mode inline
  2305. specialization with this parameter; so just use the first sym }
  2306. if not assigned(basedef.typesym) then
  2307. basedef.typesym:=ttypesym(result[firstidx]);
  2308. firstidx:=result.count;
  2309. constraintdata.free;
  2310. constraintdata := nil;
  2311. end
  2312. else
  2313. begin
  2314. if token=_SEMICOLON then
  2315. begin
  2316. { two different typeless parameters are considered as incompatible }
  2317. for i:=firstidx to result.count-1 do
  2318. if tsym(result[i]).typ<>constsym then
  2319. begin
  2320. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  2321. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  2322. end;
  2323. { a semicolon terminates a type parameter group }
  2324. firstidx:=result.count;
  2325. end;
  2326. end;
  2327. if token=_SEMICOLON then
  2328. begin
  2329. is_const:=false;
  2330. allowconst:=true;
  2331. end;
  2332. until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON));
  2333. { if the constant parameter is not terminated then the type restriction was
  2334. not specified and we need to give an error }
  2335. if is_const then
  2336. consume(_COLON);
  2337. { two different typeless parameters are considered as incompatible }
  2338. for i:=firstidx to result.count-1 do
  2339. if tsym(result[i]).typ<>constsym then
  2340. begin
  2341. ttypesym(result[i]).typedef:=cundefineddef.create(false);
  2342. ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
  2343. end;
  2344. block_type:=old_block_type;
  2345. end;
  2346. procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist;isfwd:boolean);
  2347. var
  2348. i : longint;
  2349. generictype,
  2350. fwdparam : tstoredsym;
  2351. generictypedef : tdef;
  2352. sym : tsym;
  2353. st : tsymtable;
  2354. fwdok : boolean;
  2355. conv : tconverttype;
  2356. op : tprocdef;
  2357. begin
  2358. def.genericdef:=genericdef;
  2359. if not assigned(genericlist) then
  2360. exit;
  2361. if assigned(genericdef) then
  2362. include(def.defoptions,df_specialization)
  2363. else
  2364. if genericlist.count>0 then
  2365. include(def.defoptions,df_generic);
  2366. case def.typ of
  2367. recorddef,objectdef: st:=tabstractrecorddef(def).symtable;
  2368. arraydef: st:=tarraydef(def).symtable;
  2369. procvardef,procdef: st:=tabstractprocdef(def).parast;
  2370. else
  2371. internalerror(201101020);
  2372. end;
  2373. { if we have a forwarddef we check whether the generic parameters are
  2374. equal and otherwise ignore the list }
  2375. if isfwd then
  2376. begin
  2377. fwdok:=true;
  2378. if (genericlist.count>0) and
  2379. (
  2380. not assigned(def.genericparas)
  2381. or (def.genericparas.count<>genericlist.count)
  2382. ) then
  2383. fwdok:=false
  2384. else
  2385. begin
  2386. for i:=0 to genericlist.count-1 do
  2387. begin
  2388. if def.genericparas.nameofindex(i)<>genericlist.nameofindex(i) then
  2389. begin
  2390. fwdok:=false;
  2391. break;
  2392. end;
  2393. generictype:=tstoredsym(genericlist[i]);
  2394. fwdparam:=tstoredsym(def.genericparas[i]);
  2395. op:=nil;
  2396. conv:=tc_equal;
  2397. if generictype.typ<>fwdparam.typ then
  2398. fwdok:=false
  2399. else if (generictype.typ=typesym) then
  2400. begin
  2401. if compare_defs_ext(ttypesym(generictype).typedef,ttypesym(fwdparam).typedef,nothingn,conv,op,[cdo_strict_genconstraint_check])<te_exact then
  2402. fwdok:=false;
  2403. end
  2404. else if (generictype.typ=constsym) then
  2405. begin
  2406. if (tconstsym(generictype).consttyp<>tconstsym(fwdparam).consttyp) or
  2407. (compare_defs_ext(tconstsym(generictype).constdef,tconstsym(fwdparam).constdef,nothingn,conv,op,[cdo_strict_genconstraint_check])<te_exact) then
  2408. fwdok:=false;
  2409. end
  2410. else
  2411. internalerror(2020070101);
  2412. if not fwdok then
  2413. break;
  2414. end;
  2415. end;
  2416. if not fwdok then
  2417. Message(parser_e_forward_mismatch);
  2418. exit;
  2419. end;
  2420. if (genericlist.count>0) and not assigned(def.genericparas) then
  2421. def.genericparas:=tfphashobjectlist.create(false);
  2422. for i:=0 to genericlist.count-1 do
  2423. begin
  2424. generictype:=tstoredsym(genericlist[i]);
  2425. if assigned(generictype.owner) then
  2426. begin
  2427. if generictype.typ=typesym then
  2428. sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef)
  2429. else if generictype.typ=constsym then
  2430. { generictype is a constsym that was created in create_generic_constsym
  2431. during phase 1 so we pass this directly without copying }
  2432. begin
  2433. sym:=generictype;
  2434. { the sym name is still undefined so we set it to match
  2435. the generic param name so it's accessible }
  2436. sym.realname:=genericlist.nameofindex(i);
  2437. include(sym.symoptions,sp_generic_const);
  2438. end
  2439. else
  2440. internalerror(2019021602);
  2441. { type parameters need to be added as strict private }
  2442. sym.visibility:=vis_strictprivate;
  2443. st.insertsym(sym);
  2444. include(sym.symoptions,sp_generic_para);
  2445. end
  2446. else
  2447. begin
  2448. if generictype.typ=typesym then
  2449. begin
  2450. generictypedef:=ttypesym(generictype).typedef;
  2451. if (generictypedef.typ=undefineddef) and (generictypedef<>cundefinedtype) then
  2452. begin
  2453. { the generic parameters were parsed before the genericdef existed thus the
  2454. undefineddefs were added as part of the parent symtable }
  2455. if assigned(generictypedef.owner) then
  2456. generictypedef.owner.DefList.Extract(generictypedef);
  2457. generictypedef.changeowner(st);
  2458. end;
  2459. end;
  2460. st.insertsym(generictype);
  2461. include(generictype.symoptions,sp_generic_para);
  2462. end;
  2463. def.genericparas.add(genericlist.nameofindex(i),generictype);
  2464. end;
  2465. end;
  2466. procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist);
  2467. var
  2468. gensym : ttypesym;
  2469. begin
  2470. { for generics in non-Delphi modes we insert a private type symbol
  2471. that has the same base name as the currently parsed generic and
  2472. that references this defs }
  2473. if not (m_delphi in current_settings.modeswitches) and
  2474. (
  2475. (
  2476. parse_generic and
  2477. assigned(genericlist) and
  2478. (genericlist.count>0)
  2479. ) or
  2480. (
  2481. assigned(current_specializedef) and
  2482. assigned(current_structdef.genericdef) and
  2483. (current_structdef.genericdef.typ in [objectdef,recorddef]) and
  2484. (pos('$',name)>0)
  2485. )
  2486. ) then
  2487. begin
  2488. { we need to pass nil as def here, because the constructor wants
  2489. to set the typesym of the def which is not what we want }
  2490. gensym:=ctypesym.create(copy(name,1,pos('$',name)-1),nil);
  2491. gensym.typedef:=current_structdef;
  2492. include(gensym.symoptions,sp_internal);
  2493. { the symbol should be only visible to the generic class
  2494. itself }
  2495. gensym.visibility:=vis_strictprivate;
  2496. symtablestack.top.insertsym(gensym);
  2497. end;
  2498. end;
  2499. function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:ansistring):tidstring;
  2500. var
  2501. crc : cardinal;
  2502. begin
  2503. if specializename='' then
  2504. internalerror(2012061901);
  2505. { build the new type's name }
  2506. crc:=UpdateCrc32(0,specializename[1],length(specializename));
  2507. result:=name+'$crc'+hexstr(crc,8);
  2508. if owner_hierarchy<>'' then
  2509. begin
  2510. crc:=UpdateCrc32(0,owner_hierarchy[1],length(owner_hierarchy));
  2511. result:=result+'_crc'+hexstr(crc,8);
  2512. end;
  2513. end;
  2514. procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint);
  2515. var
  2516. i,code : longint;
  2517. countstr : string;
  2518. begin
  2519. for i:=length(name) downto 1 do
  2520. if name[i]='$' then
  2521. begin
  2522. nongeneric:=copy(name,1,i-1);
  2523. countstr:=copy(name,i+1,length(name)-i);
  2524. val(countstr,count,code);
  2525. if code<>0 then
  2526. break;
  2527. exit;
  2528. end;
  2529. nongeneric:=name;
  2530. count:=0;
  2531. end;
  2532. procedure add_generic_dummysym(sym:tsym;const name:tidstring);
  2533. var
  2534. list: TFPObjectList;
  2535. srsym : tsym;
  2536. srsymtable : tsymtable;
  2537. entry : tgenericdummyentry;
  2538. n : tidstring;
  2539. begin
  2540. if sp_generic_dummy in sym.symoptions then
  2541. begin
  2542. n:=sym.name;
  2543. if n='' then
  2544. n:=name;
  2545. { did we already search for a generic with that name? }
  2546. list:=tfpobjectlist(current_module.genericdummysyms.find(n));
  2547. if not assigned(list) then
  2548. begin
  2549. list:=tfpobjectlist.create(true);
  2550. current_module.genericdummysyms.add(n,list);
  2551. end;
  2552. { is the dummy sym still "dummy"? }
  2553. if (sym.typ=typesym) and
  2554. (
  2555. { dummy sym defined in mode Delphi }
  2556. (ttypesym(sym).typedef.typ=undefineddef) or
  2557. { dummy sym defined in non-Delphi mode }
  2558. (tstoreddef(ttypesym(sym).typedef).is_generic)
  2559. ) then
  2560. begin
  2561. { do we have a non-generic type of the same name
  2562. available? }
  2563. if not searchsym_with_flags(n,srsym,srsymtable,[ssf_no_addsymref]) then
  2564. srsym:=nil;
  2565. end
  2566. else if sym.typ=procsym then
  2567. srsym:=sym
  2568. else
  2569. { dummy symbol is already not so dummy anymore }
  2570. srsym:=nil;
  2571. if assigned(srsym) then
  2572. begin
  2573. entry:=tgenericdummyentry.create;
  2574. entry.resolvedsym:=srsym;
  2575. entry.dummysym:=sym;
  2576. list.add(entry);
  2577. end;
  2578. end;
  2579. end;
  2580. function resolve_generic_dummysym(const name:tidstring):tsym;
  2581. var
  2582. list : tfpobjectlist;
  2583. begin
  2584. list:=tfpobjectlist(current_module.genericdummysyms.find(name));
  2585. if assigned(list) and (list.count>0) then
  2586. result:=tgenericdummyentry(list.last).resolvedsym
  2587. else
  2588. result:=nil;
  2589. end;
  2590. function could_be_generic(const name:tidstring):boolean;
  2591. begin
  2592. result:=(name<>'') and
  2593. (current_module.genericdummysyms.findindexof(name)>=0);
  2594. end;
  2595. function is_or_belongs_to_current_genericdef(def:tdef):boolean;
  2596. var
  2597. d : tdef;
  2598. state : pspecializationstate;
  2599. begin
  2600. result:=true;
  2601. if (def=current_genericdef) or
  2602. defs_belong_to_same_generic(def,current_genericdef) then
  2603. exit;
  2604. state:=pspecializationstate(current_module.specializestate);
  2605. while assigned(state) do
  2606. begin
  2607. if (state^.oldcurrent_genericdef=def) or
  2608. defs_belong_to_same_generic(state^.oldcurrent_genericdef,def) then
  2609. exit;
  2610. state:=state^.oldspecializestate;
  2611. end;
  2612. result:=false;
  2613. end;
  2614. procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
  2615. var
  2616. pu : tused_unit;
  2617. hmodule : tmodule;
  2618. unitsyms : TFPHashObjectList;
  2619. sym : tsym;
  2620. symtable : tsymtable;
  2621. i : Integer;
  2622. n : string;
  2623. begin
  2624. if not assigned(genericdef) then
  2625. internalerror(200705151);
  2626. { Setup symtablestack at definition time
  2627. to get types right, however this is not perfect, we should probably record
  2628. the resolved symbols }
  2629. state.oldsymtablestack:=symtablestack;
  2630. state.oldextendeddefs:=current_module.extendeddefs;
  2631. state.oldgenericdummysyms:=current_module.genericdummysyms;
  2632. state.oldcurrent_genericdef:=current_genericdef;
  2633. state.oldspecializestate:=pspecializationstate(current_module.specializestate);
  2634. state.oldoptoken:=optoken;
  2635. optoken:=NOTOKEN;
  2636. current_module.specializestate:=@state;
  2637. current_module.extendeddefs:=TFPHashObjectList.create(true);
  2638. current_module.genericdummysyms:=tfphashobjectlist.create(true);
  2639. symtablestack:=tdefawaresymtablestack.create;
  2640. if not assigned(genericdef.owner) then
  2641. hmodule:=current_module
  2642. else
  2643. hmodule:=find_module_from_symtable(genericdef.owner);
  2644. if hmodule=nil then
  2645. internalerror(200705152);
  2646. { collect all unit syms in the generic's unit as we need to establish
  2647. their unitsym.module link again so that unit identifiers can be used }
  2648. unitsyms:=tfphashobjectlist.create(false);
  2649. if (hmodule<>current_module) and assigned(hmodule.globalsymtable) then
  2650. for i:=0 to hmodule.globalsymtable.symlist.count-1 do
  2651. begin
  2652. sym:=tsym(hmodule.globalsymtable.symlist[i]);
  2653. if sym.typ=unitsym then
  2654. begin
  2655. n:=sym.realname;
  2656. if (Copy(n,1,7)='$hidden') then
  2657. Delete(n,1,7);
  2658. unitsyms.add(upper(n),sym);
  2659. end;
  2660. end;
  2661. { add all units if we are specializing inside the current unit (as the
  2662. generic could have been declared in the implementation part), but load
  2663. only interface units, if we are in a different unit as then the generic
  2664. needs to be in the interface section }
  2665. pu:=tused_unit(hmodule.used_units.first);
  2666. while assigned(pu) do
  2667. begin
  2668. if not assigned(pu.u.globalsymtable) then
  2669. { in certain circular, but valid unit constellations it can happen
  2670. that we specialize a generic in a different unit that was used
  2671. in the implementation section of the generic's unit and were the
  2672. interface is still being parsed and thus the localsymtable is in
  2673. reality the global symtable
  2674. In addition to that it can also be the case that neither the
  2675. global- nor the localsymtable is set, namely when the compiler
  2676. didn't yet have the chance to process on of the units in the
  2677. (implementation) uses clause simply due to the orders, so don't
  2678. add anything of that unit yet (once routine bodies need to be
  2679. specialized everything needed should be in place however). }
  2680. if pu.u.in_interface then
  2681. begin
  2682. if assigned(pu.u.localsymtable) then
  2683. symtablestack.push(pu.u.localsymtable)
  2684. end
  2685. else
  2686. internalerror(200705153)
  2687. else
  2688. symtablestack.push(pu.u.globalsymtable);
  2689. sym:=tsym(unitsyms.find(pu.u.modulename^));
  2690. if assigned(sym) and not assigned(tunitsym(sym).module) then
  2691. tunitsym(sym).module:=pu.u;
  2692. pu:=tused_unit(pu.next);
  2693. end;
  2694. unitsyms.free;
  2695. unitsyms := nil;
  2696. if assigned(hmodule.globalsymtable) then
  2697. symtablestack.push(hmodule.globalsymtable);
  2698. symtable:=genericdef.owner;
  2699. { push the localsymtable if needed }
  2700. if ((hmodule<>current_module) or not current_module.in_interface)
  2701. and assigned(hmodule.localsymtable) then
  2702. symtablestack.push(hmodule.localsymtable);
  2703. { also push the symtables of all owning types }
  2704. while assigned(symtable) and (symtable.symtabletype in [objectsymtable,recordsymtable]) do
  2705. begin
  2706. symtablestack.push(symtable);
  2707. if assigned(symtable.defowner) then
  2708. symtable:=symtable.defowner.owner
  2709. else
  2710. symtable:=nil;
  2711. end;
  2712. end;
  2713. procedure specialization_done(var state: tspecializationstate);
  2714. begin
  2715. { Restore symtablestack }
  2716. current_module.extendeddefs.free;
  2717. current_module.extendeddefs:=state.oldextendeddefs;
  2718. current_module.genericdummysyms.free;
  2719. current_module.genericdummysyms:=state.oldgenericdummysyms;
  2720. current_module.specializestate:=state.oldspecializestate;
  2721. optoken:=state.oldoptoken;
  2722. symtablestack.free;
  2723. symtablestack:=state.oldsymtablestack;
  2724. { clear the state record to be on the safe side }
  2725. fillchar(state, sizeof(state), 0);
  2726. end;
  2727. {****************************************************************************
  2728. SPECIALIZATION BODY GENERATION
  2729. ****************************************************************************}
  2730. procedure process_procdef(def:tprocdef;hmodule:tmodule);
  2731. var
  2732. oldcurrent_filepos : tfileposinfo;
  2733. begin
  2734. if assigned(def.genericdef) and
  2735. (def.genericdef.typ=procdef) and
  2736. assigned(tprocdef(def.genericdef).generictokenbuf) then
  2737. begin
  2738. if not assigned(tprocdef(def.genericdef).generictokenbuf) then
  2739. internalerror(2015061902);
  2740. oldcurrent_filepos:=current_filepos;
  2741. current_filepos:=tprocdef(def.genericdef).fileinfo;
  2742. { use the index the module got from the current compilation process }
  2743. current_filepos.moduleindex:=hmodule.unit_index;
  2744. current_tokenpos:=current_filepos;
  2745. current_scanner.startreplaytokens(tprocdef(def.genericdef).generictokenbuf,hmodule.change_endian);
  2746. read_proc_body(def);
  2747. current_filepos:=oldcurrent_filepos;
  2748. end
  2749. { synthetic routines will be implemented afterwards }
  2750. else if def.synthetickind=tsk_none then
  2751. MessagePos1(def.fileinfo,sym_e_forward_not_resolved,def.fullprocname(false));
  2752. end;
  2753. function process_abstractrecorddef(def:tabstractrecorddef):boolean;
  2754. var
  2755. i : longint;
  2756. hp : tdef;
  2757. hmodule : tmodule;
  2758. begin
  2759. result:=true;
  2760. hmodule:=nil;
  2761. if assigned(def.genericdef) then
  2762. hmodule:=find_module_from_symtable(def.genericdef.owner)
  2763. else if not (df_internal in def.defoptions) then
  2764. internalerror(201202041);
  2765. for i:=0 to def.symtable.DefList.Count-1 do
  2766. begin
  2767. hp:=tdef(def.symtable.DefList[i]);
  2768. if hp.typ=procdef then
  2769. begin
  2770. { only generate the code if we need a body }
  2771. if assigned(tprocdef(hp).struct) and not tprocdef(hp).forwarddef then
  2772. continue;
  2773. { and the body is available already (which is implicitly the
  2774. case if the generic routine is part of another unit) }
  2775. if (
  2776. not assigned(hmodule) or
  2777. (hmodule=current_module) or
  2778. (hmodule.state=ms_compile)
  2779. ) and
  2780. { may not be assigned in case it's a synthetic procdef that
  2781. still needs to be generated }
  2782. (assigned(tprocdef(hp).genericdef) and
  2783. tprocdef(tprocdef(hp).genericdef).forwarddef)
  2784. { when the implementation of the module was not yet parsed, it will not yet have a generictokenbuf }
  2785. or not assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
  2786. begin
  2787. result:=false;
  2788. continue;
  2789. end;
  2790. process_procdef(tprocdef(hp),hmodule);
  2791. end
  2792. else
  2793. if hp.typ in [objectdef,recorddef] then
  2794. { generate code for subtypes as well }
  2795. result:=process_abstractrecorddef(tabstractrecorddef(hp)) and result;
  2796. end;
  2797. end;
  2798. procedure generate_specialization_procs;
  2799. var
  2800. i : longint;
  2801. list,
  2802. readdlist : tfpobjectlist;
  2803. def : tstoreddef;
  2804. state : tspecializationstate;
  2805. hmodule : tmodule;
  2806. mstate : tmodulestate;
  2807. begin
  2808. { first copy all entries and then work with that list to ensure that
  2809. we don't get an infinite recursion }
  2810. list:=tfpobjectlist.create(false);
  2811. readdlist:=tfpobjectlist.create(false);
  2812. list.Capacity:=current_module.pendingspecializations.Count;
  2813. for i:=0 to current_module.pendingspecializations.Count-1 do
  2814. list.add(current_module.pendingspecializations.Items[i]);
  2815. current_module.pendingspecializations.clear;
  2816. for i:=0 to list.count-1 do
  2817. begin
  2818. def:=tstoreddef(list[i]);
  2819. if not tstoreddef(def).is_specialization then
  2820. continue;
  2821. case def.typ of
  2822. procdef:
  2823. begin
  2824. { the use of forwarddef should not backfire as the
  2825. specialization always belongs to the current module }
  2826. if not tprocdef(def).forwarddef then
  2827. continue;
  2828. if not assigned(def.genericdef) then
  2829. internalerror(2015061903);
  2830. hmodule:=find_module_from_symtable(def.genericdef.owner);
  2831. if hmodule=nil then
  2832. internalerror(2015061904);
  2833. { we need to check for a forward declaration only if the
  2834. generic was declared in the same unit (otherwise there
  2835. should be one) }
  2836. mstate:=hmodule.state;
  2837. if ((hmodule=current_module) or (hmodule.state<ms_compiling_waitfinish))
  2838. and tprocdef(def.genericdef).forwarddef then
  2839. begin
  2840. readdlist.add(def);
  2841. continue;
  2842. end;
  2843. specialization_init(tstoreddef(def).genericdef,state);
  2844. process_procdef(tprocdef(def),hmodule);
  2845. specialization_done(state);
  2846. end;
  2847. recorddef,
  2848. objectdef:
  2849. begin
  2850. specialization_init(tstoreddef(def).genericdef,state);
  2851. if not process_abstractrecorddef(tabstractrecorddef(def)) then
  2852. readdlist.add(def);
  2853. specialization_done(state);
  2854. end;
  2855. else
  2856. ;
  2857. end;
  2858. end;
  2859. { add those defs back to the pending list for which we don't yet have
  2860. all method bodies }
  2861. for i:=0 to readdlist.count-1 do
  2862. current_module.pendingspecializations.add(tstoreddef(readdlist[i]).typename,readdlist[i]);
  2863. readdlist.free;
  2864. readdlist := nil;
  2865. list.free;
  2866. list := nil;
  2867. end;
  2868. procedure generate_specializations_for_forwarddef(def:tdef);
  2869. var
  2870. list : tfpobjectlist;
  2871. idx,
  2872. i : longint;
  2873. context : tspecializationcontext;
  2874. begin
  2875. if not tstoreddef(def).is_generic then
  2876. internalerror(2020070304);
  2877. idx:=current_module.forwardgenericdefs.findindexof(def.fulltypename);
  2878. if idx<0 then
  2879. exit;
  2880. list:=tfpobjectlist(current_module.forwardgenericdefs.items[idx]);
  2881. if not assigned(list) then
  2882. internalerror(2020070305);
  2883. for i:=0 to list.count-1 do begin
  2884. context:=tspecializationcontext(list[i]);
  2885. generate_specialization_phase2(context,tstoreddef(def),false,'');
  2886. end;
  2887. current_module.forwardgenericdefs.delete(idx);
  2888. end;
  2889. procedure maybe_add_pending_specialization(def:tdef;unnamed_syms: tfplist);
  2890. var
  2891. hmodule : tmodule;
  2892. st : tsymtable;
  2893. i : integer;
  2894. begin
  2895. if parse_generic then
  2896. exit;
  2897. { transfer ownership of any unnamed syms to be the specialization }
  2898. if unnamed_syms<>nil then
  2899. transfer_unnamed_symbols(tprocdef(def).parast,unnamed_syms);
  2900. st:=def.owner;
  2901. while st.symtabletype in [localsymtable] do
  2902. st:=st.defowner.owner;
  2903. hmodule:=find_module_from_symtable(st);
  2904. if tstoreddef(def).is_specialization and (hmodule=current_module) then
  2905. current_module.pendingspecializations.add(def.typename,def);
  2906. end;
  2907. function determine_generic_def(const name:tidstring):tstoreddef;
  2908. var
  2909. hashedid : THashedIDString;
  2910. pd : tprocdef;
  2911. sym : tsym;
  2912. begin
  2913. result:=nil;
  2914. { check whether this is a declaration of a type inside a
  2915. specialization }
  2916. if assigned(current_structdef) and
  2917. (df_specialization in current_structdef.defoptions) then
  2918. begin
  2919. if not assigned(current_structdef.genericdef) or
  2920. not (current_structdef.genericdef.typ in [recorddef,objectdef]) then
  2921. internalerror(2011052301);
  2922. hashedid.id:=name;
  2923. { we could be inside a method of the specialization
  2924. instead of its declaration, so check that first (as
  2925. local nested types aren't allowed we don't need to
  2926. walk the symtablestack to find the localsymtable) }
  2927. if symtablestack.top.symtabletype=localsymtable then
  2928. begin
  2929. { we are in a method }
  2930. if not assigned(symtablestack.top.defowner) or
  2931. (symtablestack.top.defowner.typ<>procdef) then
  2932. internalerror(2011120701);
  2933. pd:=tprocdef(symtablestack.top.defowner);
  2934. if not assigned(pd.genericdef) or (pd.genericdef.typ<>procdef) then
  2935. internalerror(2011120702);
  2936. sym:=tsym(tprocdef(pd.genericdef).localst.findwithhash(hashedid));
  2937. end
  2938. else
  2939. sym:=nil;
  2940. if not assigned(sym) or not (sym.typ=typesym) then
  2941. begin
  2942. { now search in the declaration of the generic }
  2943. sym:=tsym(tabstractrecorddef(current_structdef.genericdef).symtable.findwithhash(hashedid));
  2944. if not assigned(sym) or not (sym.typ=typesym) then
  2945. internalerror(2011052302);
  2946. end;
  2947. { use the corresponding type in the generic's symtable as
  2948. genericdef for the specialized type }
  2949. result:=tstoreddef(ttypesym(sym).typedef);
  2950. end;
  2951. end;
  2952. end.