psub.pas 70 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
  3. Does the parsing and codegeneration at subroutine level
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit psub;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. cclasses,globals,
  22. node,nbas,
  23. symdef,procinfo;
  24. type
  25. tcgprocinfo = class(tprocinfo)
  26. private
  27. procedure add_entry_exit_code;
  28. public
  29. { code for the subroutine as tree }
  30. code : tnode;
  31. { positions in the tree for init/final }
  32. entry_asmnode,
  33. loadpara_asmnode,
  34. exitlabel_asmnode,
  35. stackcheck_asmnode,
  36. init_asmnode,
  37. final_asmnode : tasmnode;
  38. { list to store the procinfo's of the nested procedures }
  39. nestedprocs : tlinkedlist;
  40. constructor create(aparent:tprocinfo);override;
  41. destructor destroy;override;
  42. procedure printproc;
  43. procedure generate_code;
  44. procedure resetprocdef;
  45. procedure add_to_symtablestack;
  46. procedure remove_from_symtablestack;
  47. procedure parse_body;
  48. function stack_tainting_parameter : boolean;
  49. function has_assembler_child : boolean;
  50. end;
  51. procedure printnode_reset;
  52. { reads the declaration blocks }
  53. procedure read_declarations(islibrary : boolean);
  54. { reads declarations in the interface part of a unit }
  55. procedure read_interface_declarations;
  56. procedure generate_specialization_procs;
  57. implementation
  58. uses
  59. sysutils,
  60. { common }
  61. cutils,
  62. { global }
  63. globtype,tokens,verbose,comphook,constexp,
  64. systems,
  65. { aasm }
  66. cpubase,aasmbase,aasmtai,aasmdata,
  67. { symtable }
  68. symconst,symbase,symsym,symtype,symtable,defutil,
  69. paramgr,
  70. ppu,fmodule,
  71. { pass 1 }
  72. nutils,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
  73. pass_1,
  74. {$ifdef state_tracking}
  75. nstate,
  76. {$endif state_tracking}
  77. { pass 2 }
  78. {$ifndef NOPASS2}
  79. pass_2,
  80. {$endif}
  81. { parser }
  82. scanner,import,gendef,
  83. pbase,pstatmnt,pdecl,pdecsub,pexports,
  84. { codegen }
  85. tgobj,cgbase,cgobj,dbgbase,
  86. ncgutil,regvars,
  87. optbase,
  88. opttail,
  89. optcse,
  90. optdfa,
  91. optutils
  92. {$if defined(arm) or defined(powerpc) or defined(powerpc64)}
  93. ,aasmcpu
  94. {$endif arm}
  95. {$ifndef NOOPT}
  96. {$ifdef i386}
  97. ,aopt386
  98. {$else i386}
  99. ,aopt
  100. {$endif i386}
  101. {$endif}
  102. ;
  103. {****************************************************************************
  104. PROCEDURE/FUNCTION BODY PARSING
  105. ****************************************************************************}
  106. procedure initializevars(p:TObject;arg:pointer);
  107. var
  108. b : tblocknode;
  109. begin
  110. if not (tsym(p).typ in [localvarsym,staticvarsym]) then
  111. exit;
  112. with tabstractnormalvarsym(p) do
  113. begin
  114. if assigned(defaultconstsym) then
  115. begin
  116. b:=tblocknode(arg);
  117. b.left:=cstatementnode.create(
  118. cassignmentnode.create(
  119. cloadnode.create(tsym(p),tsym(p).owner),
  120. cloadnode.create(defaultconstsym,defaultconstsym.owner)),
  121. b.left);
  122. end;
  123. end;
  124. end;
  125. procedure check_finalize_paras(p:TObject;arg:pointer);
  126. begin
  127. if (tsym(p).typ=paravarsym) and
  128. (tparavarsym(p).varspez=vs_value) and
  129. not is_class(tparavarsym(p).vardef) and
  130. tparavarsym(p).vardef.needs_inittable then
  131. include(current_procinfo.flags,pi_needs_implicit_finally);
  132. end;
  133. procedure check_finalize_locals(p:TObject;arg:pointer);
  134. begin
  135. if (tsym(p).typ=localvarsym) and
  136. (tlocalvarsym(p).refs>0) and
  137. not(vo_is_funcret in tlocalvarsym(p).varoptions) and
  138. not(is_class(tlocalvarsym(p).vardef)) and
  139. tlocalvarsym(p).vardef.needs_inittable then
  140. include(current_procinfo.flags,pi_needs_implicit_finally);
  141. end;
  142. function block(islibrary : boolean) : tnode;
  143. begin
  144. { parse const,types and vars }
  145. read_declarations(islibrary);
  146. { do we have an assembler block without the po_assembler?
  147. we should allow this for Delphi compatibility (PFV) }
  148. if (token=_ASM) and (m_delphi in current_settings.modeswitches) then
  149. include(current_procinfo.procdef.procoptions,po_assembler);
  150. { Handle assembler block different }
  151. if (po_assembler in current_procinfo.procdef.procoptions) then
  152. begin
  153. block:=assembler_block;
  154. exit;
  155. end;
  156. {Unit initialization?.}
  157. if (
  158. assigned(current_procinfo.procdef.localst) and
  159. (current_procinfo.procdef.localst.symtablelevel=main_program_level) and
  160. (current_module.is_unit)
  161. ) or
  162. islibrary then
  163. begin
  164. if (token=_END) then
  165. begin
  166. consume(_END);
  167. { We need at least a node, else the entry/exit code is not
  168. generated and thus no PASCALMAIN symbol which we need (PFV) }
  169. if islibrary then
  170. block:=cnothingnode.create
  171. else
  172. block:=nil;
  173. end
  174. else
  175. begin
  176. if token=_INITIALIZATION then
  177. begin
  178. { The library init code is already called and does not
  179. need to be in the initfinal table (PFV) }
  180. if not islibrary then
  181. current_module.flags:=current_module.flags or uf_init;
  182. block:=statement_block(_INITIALIZATION);
  183. end
  184. else if (token=_FINALIZATION) then
  185. begin
  186. if (current_module.flags and uf_finalize)<>0 then
  187. block:=statement_block(_FINALIZATION)
  188. else
  189. begin
  190. { can we allow no INITIALIZATION for DLL ??
  191. I think it should work PM }
  192. block:=nil;
  193. exit;
  194. end;
  195. end
  196. else
  197. begin
  198. { The library init code is already called and does not
  199. need to be in the initfinal table (PFV) }
  200. if not islibrary then
  201. current_module.flags:=current_module.flags or uf_init;
  202. block:=statement_block(_BEGIN);
  203. end;
  204. end;
  205. end
  206. else
  207. begin
  208. block:=statement_block(_BEGIN);
  209. if current_procinfo.procdef.localst.symtabletype=localsymtable then
  210. current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
  211. end;
  212. end;
  213. {****************************************************************************
  214. PROCEDURE/FUNCTION COMPILING
  215. ****************************************************************************}
  216. procedure printnode_reset;
  217. begin
  218. assign(printnodefile,treelogfilename);
  219. {$I-}
  220. rewrite(printnodefile);
  221. {$I+}
  222. if ioresult<>0 then
  223. begin
  224. Comment(V_Error,'Error creating '+treelogfilename);
  225. exit;
  226. end;
  227. close(printnodefile);
  228. end;
  229. function generate_bodyentry_block:tnode;
  230. var
  231. srsym : tsym;
  232. para : tcallparanode;
  233. newstatement : tstatementnode;
  234. hdef : tdef;
  235. begin
  236. result:=internalstatements(newstatement);
  237. if assigned(current_procinfo.procdef._class) then
  238. begin
  239. { a constructor needs a help procedure }
  240. if (current_procinfo.procdef.proctypeoption=potype_constructor) then
  241. begin
  242. if is_class(current_procinfo.procdef._class) then
  243. begin
  244. include(current_procinfo.flags,pi_needs_implicit_finally);
  245. srsym:=search_class_member(current_procinfo.procdef._class,'NEWINSTANCE');
  246. if assigned(srsym) and
  247. (srsym.typ=procsym) then
  248. begin
  249. { if vmt>1 then newinstance }
  250. addstatement(newstatement,cifnode.create(
  251. caddnode.create(gtn,
  252. ctypeconvnode.create_internal(
  253. load_vmt_pointer_node,
  254. voidpointertype),
  255. cpointerconstnode.create(1,voidpointertype)),
  256. cassignmentnode.create(
  257. ctypeconvnode.create_internal(
  258. load_self_pointer_node,
  259. voidpointertype),
  260. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_vmt_pointer_node,[])),
  261. nil));
  262. end
  263. else
  264. internalerror(200305108);
  265. end
  266. else
  267. if is_object(current_procinfo.procdef._class) then
  268. begin
  269. hdef:=current_procinfo.procdef._class;
  270. hdef:=tpointerdef.create(hdef);
  271. { parameter 3 : vmt_offset }
  272. { parameter 2 : address of pointer to vmt,
  273. this is required to allow setting the vmt to -1 to indicate
  274. that memory was allocated }
  275. { parameter 1 : self pointer }
  276. para:=ccallparanode.create(
  277. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  278. ccallparanode.create(
  279. ctypeconvnode.create_internal(
  280. load_vmt_pointer_node,
  281. voidpointertype),
  282. ccallparanode.create(
  283. ctypeconvnode.create_internal(
  284. load_self_pointer_node,
  285. voidpointertype),
  286. nil)));
  287. addstatement(newstatement,cassignmentnode.create(
  288. ctypeconvnode.create_internal(
  289. load_self_pointer_node,
  290. voidpointertype),
  291. ccallnode.createintern('fpc_help_constructor',para)));
  292. end
  293. else
  294. internalerror(200305103);
  295. { if self=nil then exit
  296. calling fail instead of exit is useless because
  297. there is nothing to dispose (PFV) }
  298. addstatement(newstatement,cifnode.create(
  299. caddnode.create(equaln,
  300. load_self_pointer_node,
  301. cnilnode.create),
  302. cexitnode.create(nil),
  303. nil));
  304. end;
  305. { maybe call BeforeDestruction for classes }
  306. if (current_procinfo.procdef.proctypeoption=potype_destructor) and
  307. is_class(current_procinfo.procdef._class) then
  308. begin
  309. srsym:=search_class_member(current_procinfo.procdef._class,'BEFOREDESTRUCTION');
  310. if assigned(srsym) and
  311. (srsym.typ=procsym) then
  312. begin
  313. { if vmt>0 then beforedestruction }
  314. addstatement(newstatement,cifnode.create(
  315. caddnode.create(gtn,
  316. ctypeconvnode.create_internal(
  317. load_vmt_pointer_node,ptrsinttype),
  318. ctypeconvnode.create_internal(
  319. cnilnode.create,ptrsinttype)),
  320. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  321. nil));
  322. end
  323. else
  324. internalerror(200305104);
  325. end;
  326. end;
  327. end;
  328. function generate_bodyexit_block:tnode;
  329. var
  330. srsym : tsym;
  331. para : tcallparanode;
  332. newstatement : tstatementnode;
  333. oldlocalswitches: tlocalswitches;
  334. begin
  335. result:=internalstatements(newstatement);
  336. if assigned(current_procinfo.procdef._class) then
  337. begin
  338. { Don't test self and the vmt here. The reason is that }
  339. { a constructor already checks whether these are valid }
  340. { before. Further, in case of TThread the thread may }
  341. { free the class instance right after AfterConstruction }
  342. { has been called, so it may no longer be valid (JM) }
  343. oldlocalswitches:=current_settings.localswitches;
  344. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  345. { maybe call AfterConstruction for classes }
  346. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  347. is_class(current_procinfo.procdef._class) then
  348. begin
  349. srsym:=search_class_member(current_procinfo.procdef._class,'AFTERCONSTRUCTION');
  350. if assigned(srsym) and
  351. (srsym.typ=procsym) then
  352. begin
  353. { Self can be nil when fail is called }
  354. { if self<>nil and vmt<>nil then afterconstruction }
  355. addstatement(newstatement,cifnode.create(
  356. caddnode.create(andn,
  357. caddnode.create(unequaln,
  358. load_self_pointer_node,
  359. cnilnode.create),
  360. caddnode.create(unequaln,
  361. load_vmt_pointer_node,
  362. cnilnode.create)),
  363. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  364. nil));
  365. end
  366. else
  367. internalerror(200305106);
  368. end;
  369. { a destructor needs a help procedure }
  370. if (current_procinfo.procdef.proctypeoption=potype_destructor) then
  371. begin
  372. if is_class(current_procinfo.procdef._class) then
  373. begin
  374. srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE');
  375. if assigned(srsym) and
  376. (srsym.typ=procsym) then
  377. begin
  378. { if self<>0 and vmt<>0 then freeinstance }
  379. addstatement(newstatement,cifnode.create(
  380. caddnode.create(andn,
  381. caddnode.create(unequaln,
  382. load_self_pointer_node,
  383. cnilnode.create),
  384. caddnode.create(unequaln,
  385. ctypeconvnode.create(
  386. load_vmt_pointer_node,
  387. voidpointertype),
  388. cpointerconstnode.create(0,voidpointertype))),
  389. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  390. nil));
  391. end
  392. else
  393. internalerror(200305108);
  394. end
  395. else
  396. if is_object(current_procinfo.procdef._class) then
  397. begin
  398. { finalize object data }
  399. if current_procinfo.procdef._class.needs_inittable then
  400. addstatement(newstatement,finalize_data_node(load_self_node));
  401. { parameter 3 : vmt_offset }
  402. { parameter 2 : pointer to vmt }
  403. { parameter 1 : self pointer }
  404. para:=ccallparanode.create(
  405. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  406. ccallparanode.create(
  407. ctypeconvnode.create_internal(
  408. load_vmt_pointer_node,
  409. voidpointertype),
  410. ccallparanode.create(
  411. ctypeconvnode.create_internal(
  412. load_self_pointer_node,
  413. voidpointertype),
  414. nil)));
  415. addstatement(newstatement,
  416. ccallnode.createintern('fpc_help_destructor',para));
  417. end
  418. else
  419. internalerror(200305105);
  420. end;
  421. current_settings.localswitches:=oldlocalswitches;
  422. end;
  423. end;
  424. function generate_except_block:tnode;
  425. var
  426. pd : tprocdef;
  427. newstatement : tstatementnode;
  428. oldlocalswitches: tlocalswitches;
  429. begin
  430. generate_except_block:=internalstatements(newstatement);
  431. { a constructor needs call destructor (if available) when it
  432. is not inherited }
  433. if assigned(current_procinfo.procdef._class) and
  434. (current_procinfo.procdef.proctypeoption=potype_constructor) then
  435. begin
  436. { Don't test self and the vmt here. See generate_bodyexit_block }
  437. { why (JM) }
  438. oldlocalswitches:=current_settings.localswitches;
  439. current_settings.localswitches:=oldlocalswitches-[cs_check_object,cs_check_range];
  440. pd:=current_procinfo.procdef._class.Finddestructor;
  441. if assigned(pd) then
  442. begin
  443. { if vmt<>0 then call destructor }
  444. addstatement(newstatement,cifnode.create(
  445. caddnode.create(unequaln,
  446. load_vmt_pointer_node,
  447. cnilnode.create),
  448. { cnf_create_failed -> don't call BeforeDestruction }
  449. ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[cnf_create_failed]),
  450. nil));
  451. end;
  452. current_settings.localswitches:=oldlocalswitches;
  453. end
  454. else
  455. begin
  456. { no constructor }
  457. { must be the return value finalized before reraising the exception? }
  458. if (not is_void(current_procinfo.procdef.returndef)) and
  459. (current_procinfo.procdef.returndef.needs_inittable) and
  460. (not is_class(current_procinfo.procdef.returndef)) then
  461. addstatement(newstatement,finalize_data_node(load_result_node));
  462. end;
  463. end;
  464. {****************************************************************************
  465. TCGProcInfo
  466. ****************************************************************************}
  467. constructor tcgprocinfo.create(aparent:tprocinfo);
  468. begin
  469. inherited Create(aparent);
  470. nestedprocs:=tlinkedlist.create;
  471. end;
  472. destructor tcgprocinfo.destroy;
  473. begin
  474. nestedprocs.free;
  475. if assigned(code) then
  476. code.free;
  477. inherited destroy;
  478. end;
  479. procedure tcgprocinfo.printproc;
  480. begin
  481. assign(printnodefile,treelogfilename);
  482. {$I-}
  483. append(printnodefile);
  484. if ioresult<>0 then
  485. rewrite(printnodefile);
  486. {$I+}
  487. if ioresult<>0 then
  488. begin
  489. Comment(V_Error,'Error creating '+treelogfilename);
  490. exit;
  491. end;
  492. writeln(printnodefile);
  493. writeln(printnodefile,'*******************************************************************************');
  494. writeln(printnodefile,procdef.fullprocname(false));
  495. writeln(printnodefile,'*******************************************************************************');
  496. printnode(printnodefile,code);
  497. close(printnodefile);
  498. end;
  499. procedure tcgprocinfo.add_entry_exit_code;
  500. var
  501. finalcode,
  502. bodyentrycode,
  503. bodyexitcode,
  504. exceptcode : tnode;
  505. newblock : tblocknode;
  506. codestatement,
  507. newstatement : tstatementnode;
  508. oldfilepos : tfileposinfo;
  509. begin
  510. oldfilepos:=current_filepos;
  511. { Generate code/locations used at start of proc }
  512. current_filepos:=entrypos;
  513. entry_asmnode:=casmnode.create_get_position;
  514. loadpara_asmnode:=casmnode.create_get_position;
  515. stackcheck_asmnode:=casmnode.create_get_position;
  516. init_asmnode:=casmnode.create_get_position;
  517. bodyentrycode:=generate_bodyentry_block;
  518. { Generate code/locations used at end of proc }
  519. current_filepos:=exitpos;
  520. exitlabel_asmnode:=casmnode.create_get_position;
  521. final_asmnode:=casmnode.create_get_position;
  522. bodyexitcode:=generate_bodyexit_block;
  523. { Generate procedure by combining init+body+final,
  524. depending on the implicit finally we need to add
  525. an try...finally...end wrapper }
  526. newblock:=internalstatements(newstatement);
  527. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  528. (pi_needs_implicit_finally in flags) and
  529. { but it's useless in init/final code of units }
  530. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
  531. begin
  532. { Generate special exception block only needed when
  533. implicit finaly is used }
  534. current_filepos:=exitpos;
  535. exceptcode:=generate_except_block;
  536. { Generate code that will be in the try...finally }
  537. finalcode:=internalstatements(codestatement);
  538. addstatement(codestatement,final_asmnode);
  539. { Initialize before try...finally...end frame }
  540. addstatement(newstatement,loadpara_asmnode);
  541. addstatement(newstatement,stackcheck_asmnode);
  542. addstatement(newstatement,entry_asmnode);
  543. addstatement(newstatement,init_asmnode);
  544. addstatement(newstatement,bodyentrycode);
  545. current_filepos:=entrypos;
  546. addstatement(newstatement,ctryfinallynode.create_implicit(
  547. code,
  548. finalcode,
  549. exceptcode));
  550. addstatement(newstatement,exitlabel_asmnode);
  551. addstatement(newstatement,bodyexitcode);
  552. { set flag the implicit finally has been generated }
  553. include(flags,pi_has_implicit_finally);
  554. end
  555. else
  556. begin
  557. addstatement(newstatement,loadpara_asmnode);
  558. addstatement(newstatement,stackcheck_asmnode);
  559. addstatement(newstatement,entry_asmnode);
  560. addstatement(newstatement,init_asmnode);
  561. addstatement(newstatement,bodyentrycode);
  562. addstatement(newstatement,code);
  563. addstatement(newstatement,exitlabel_asmnode);
  564. addstatement(newstatement,bodyexitcode);
  565. addstatement(newstatement,final_asmnode);
  566. end;
  567. do_firstpass(newblock);
  568. code:=newblock;
  569. current_filepos:=oldfilepos;
  570. end;
  571. procedure clearrefs(p:TObject;arg:pointer);
  572. begin
  573. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) then
  574. if tabstractvarsym(p).refs>1 then
  575. tabstractvarsym(p).refs:=1;
  576. end;
  577. procedure translate_registers(p:TObject;list:pointer);
  578. begin
  579. if (tsym(p).typ in [localvarsym,paravarsym,staticvarsym]) and
  580. (tabstractnormalvarsym(p).localloc.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_MMREGISTER,
  581. LOC_CMMREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
  582. begin
  583. if not(cs_no_regalloc in current_settings.globalswitches) then
  584. cg.translate_register(tabstractnormalvarsym(p).localloc.register);
  585. if cs_asm_source in current_settings.globalswitches then
  586. TAsmList(list).concat(Tai_comment.Create(strpnew('Var '+tabstractnormalvarsym(p).realname+' located in register '+
  587. std_regname(tabstractnormalvarsym(p).localloc.register))))
  588. end;
  589. end;
  590. procedure check_for_stack(p:TObject;arg:pointer);
  591. begin
  592. if tsym(p).typ=paravarsym then
  593. begin
  594. { check if there no parameter of the current procedure is stack dependend }
  595. if is_open_array(tparavarsym(p).vardef) or
  596. is_array_of_const(tparavarsym(p).vardef) then
  597. pboolean(arg)^:=true;
  598. if assigned(p) and
  599. assigned(tparavarsym(p).paraloc[calleeside].location) and
  600. (tparavarsym(p).paraloc[calleeside].location^.loc=LOC_REFERENCE) then
  601. pboolean(arg)^:=true;
  602. end;
  603. end;
  604. function tcgprocinfo.stack_tainting_parameter : boolean;
  605. begin
  606. result:=false;
  607. procdef.parast.SymList.ForEachCall(@check_for_stack,@result);
  608. end;
  609. function tcgprocinfo.has_assembler_child : boolean;
  610. var
  611. hp : tcgprocinfo;
  612. begin
  613. result:=false;
  614. hp:=tcgprocinfo(nestedprocs.first);
  615. while assigned(hp) do
  616. begin
  617. if (hp.flags*[pi_has_assembler_block,pi_is_assembler])<>[] then
  618. begin
  619. result:=true;
  620. exit;
  621. end;
  622. hp:=tcgprocinfo(hp.next);
  623. end;
  624. end;
  625. procedure tcgprocinfo.generate_code;
  626. var
  627. oldprocinfo : tprocinfo;
  628. oldmaxfpuregisters : longint;
  629. oldfilepos : tfileposinfo;
  630. templist : TAsmList;
  631. headertai : tai;
  632. i : integer;
  633. varsym : tabstractnormalvarsym;
  634. begin
  635. { the initialization procedure can be empty, then we
  636. don't need to generate anything. When it was an empty
  637. procedure there would be at least a blocknode }
  638. if not assigned(code) then
  639. exit;
  640. { We need valid code }
  641. if Errorcount<>0 then
  642. exit;
  643. { No code can be generated for generic template }
  644. if (df_generic in procdef.defoptions) then
  645. internalerror(200511152);
  646. { The RA and Tempgen shall not be available yet }
  647. if assigned(tg) then
  648. internalerror(200309201);
  649. oldprocinfo:=current_procinfo;
  650. oldfilepos:=current_filepos;
  651. oldmaxfpuregisters:=current_settings.maxfpuregisters;
  652. current_procinfo:=self;
  653. current_filepos:=entrypos;
  654. templist:=TAsmList.create;
  655. { add parast/localst to symtablestack }
  656. add_to_symtablestack;
  657. { when size optimization only count occurrence }
  658. if cs_opt_size in current_settings.optimizerswitches then
  659. cg.t_times:=1
  660. else
  661. { reference for repetition is 100 }
  662. cg.t_times:=100;
  663. { clear register count }
  664. procdef.localst.SymList.ForEachCall(@clearrefs,nil);
  665. procdef.parast.SymList.ForEachCall(@clearrefs,nil);
  666. { there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
  667. if (procdef.localst.symtablelevel=main_program_level) and
  668. (not current_module.is_unit) then
  669. include(flags,pi_do_call);
  670. { set implicit_finally flag when there are locals/paras to be finalized }
  671. procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
  672. procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
  673. {$if defined(x86) or defined(arm)}
  674. { set implicit_finally flag for if procedure is safecall }
  675. if procdef.proccalloption=pocall_safecall then
  676. include(flags, pi_needs_implicit_finally);
  677. {$endif}
  678. { firstpass everything }
  679. flowcontrol:=[];
  680. do_firstpass(code);
  681. if code.registersfpu>0 then
  682. include(flags,pi_uses_fpu);
  683. { do this before adding the entry code else the tail recursion recognition won't work,
  684. if this causes troubles, it must be if'ed
  685. }
  686. if (cs_opt_tailrecursion in current_settings.optimizerswitches) and
  687. (pi_is_recursive in flags) then
  688. do_opttail(code,procdef);
  689. if (cs_opt_nodedfa in current_settings.optimizerswitches) and
  690. { creating dfa is not always possible }
  691. ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
  692. pi_needs_implicit_finally,pi_has_implicit_finally,pi_has_stackparameter,
  693. pi_needs_stackframe])=[]) then
  694. begin
  695. createdfainfo(code);
  696. { when life info is available, we can give more sophisticated warning about unintialized
  697. variables }
  698. { iterate through life info of the first node }
  699. for i:=0 to nodemap.count-1 do
  700. begin
  701. if DFASetIn(code.optinfo^.life,i) then
  702. case tnode(nodemap[i]).nodetype of
  703. loadn:
  704. begin
  705. varsym:=tabstractnormalvarsym(tloadnode(nodemap[i]).symtableentry);
  706. { Give warning/note for living locals }
  707. if assigned(varsym.owner) and
  708. not(vo_is_external in varsym.varoptions) then
  709. begin
  710. if (vo_is_funcret in varsym.varoptions) then
  711. CGMessage(sym_w_function_result_uninitialized)
  712. else
  713. begin
  714. if varsym.owner=procdef.localst then
  715. CGMessage1(sym_w_uninitialized_local_variable,varsym.realname);
  716. end;
  717. end;
  718. end;
  719. end;
  720. end;
  721. end;
  722. if cs_opt_nodecse in current_settings.optimizerswitches then
  723. do_optcse(code);
  724. { add implicit entry and exit code }
  725. add_entry_exit_code;
  726. { only do secondpass if there are no errors }
  727. if (ErrorCount=0) then
  728. begin
  729. { set the start offset to the start of the temp area in the stack }
  730. tg:=ttgobj.create;
  731. {$if defined(x86) or defined(arm)}
  732. { try to strip the stack frame }
  733. { set the framepointer to esp if:
  734. - no assembler directive, those are handled in assembler_block
  735. in pstatment.pas (for cases not caught by the Delphi
  736. exception below)
  737. - no exceptions are used
  738. - no debug info
  739. - no pushes are used/esp modifications, could be:
  740. * outgoing parameters on the stack
  741. * incoming parameters on the stack
  742. * open arrays
  743. - no inline assembler
  744. or
  745. - Delphi mode
  746. - assembler directive
  747. - no pushes are used/esp modifications, could be:
  748. * outgoing parameters on the stack
  749. * incoming parameters on the stack
  750. * open arrays
  751. - no local variables
  752. }
  753. if ((po_assembler in procdef.procoptions) and
  754. (m_delphi in current_settings.modeswitches) and
  755. { localst at main_program_level is a staticsymtable }
  756. (procdef.localst.symtablelevel<>main_program_level) and
  757. (tabstractlocalsymtable(procdef.localst).count_locals = 0)) or
  758. ((cs_opt_stackframe in current_settings.optimizerswitches) and
  759. not(cs_generate_stackframes in current_settings.localswitches) and
  760. not(po_assembler in procdef.procoptions) and
  761. ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,
  762. pi_needs_implicit_finally,pi_has_implicit_finally,pi_has_stackparameter,
  763. pi_needs_stackframe])=[])
  764. {$ifdef arm}
  765. and ((cs_fp_emulation in current_settings.moduleswitches) or not (pi_uses_fpu in flags))
  766. {$endif arm}
  767. )
  768. then
  769. begin
  770. { we need the parameter info here to determine if the procedure gets
  771. parameters on the stack
  772. calling generate_parameter_info doesn't hurt but it costs time
  773. }
  774. generate_parameter_info;
  775. if not(stack_tainting_parameter) and
  776. not(has_assembler_child) and (para_stack_size=0) then
  777. begin
  778. { Only need to set the framepointer }
  779. framepointer:=NR_STACK_POINTER_REG;
  780. tg.direction:=1;
  781. end;
  782. end;
  783. {$endif}
  784. { Create register allocator }
  785. cg.init_register_allocators;
  786. set_first_temp_offset;
  787. generate_parameter_info;
  788. { Allocate space in temp/registers for parast and localst }
  789. current_filepos:=entrypos;
  790. gen_alloc_symtable(aktproccode,procdef.parast);
  791. gen_alloc_symtable(aktproccode,procdef.localst);
  792. { Store temp offset for information about 'real' temps }
  793. tempstart:=tg.lasttemp;
  794. { Generate code to load register parameters in temps and insert local
  795. copies for values parameters. This must be done before the code for the
  796. body is generated because the localloc is updated.
  797. Note: The generated code will be inserted after the code generation of
  798. the body is finished, because only then the position is known }
  799. {$ifdef oldregvars}
  800. assign_regvars(code);
  801. {$endif oldreg}
  802. current_filepos:=entrypos;
  803. { record which registers are allocated here, since all code }
  804. { allocating registers comes after it }
  805. cg.set_regalloc_extend_backwards(true);
  806. gen_load_para_value(templist);
  807. cg.set_regalloc_extend_backwards(false);
  808. { caller paraloc info is also necessary in the stackframe_entry
  809. code of the ppc (and possibly other processors) }
  810. if not procdef.has_paraloc_info then
  811. begin
  812. procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
  813. procdef.has_paraloc_info:=true;
  814. end;
  815. { generate code for the node tree }
  816. do_secondpass(code);
  817. aktproccode.concatlist(current_asmdata.CurrAsmList);
  818. {$ifdef i386}
  819. procdef.fpu_used:=code.registersfpu;
  820. {$endif i386}
  821. { The position of the loadpara_asmnode is now known }
  822. aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
  823. { first generate entry and initialize code with the correct
  824. position and switches }
  825. current_filepos:=entrypos;
  826. current_settings.localswitches:=entryswitches;
  827. cg.set_regalloc_extend_backwards(true);
  828. gen_entry_code(templist);
  829. aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
  830. gen_initialize_code(templist);
  831. aktproccode.insertlistafter(init_asmnode.currenttai,templist);
  832. { now generate finalize and exit code with the correct position
  833. and switches }
  834. current_filepos:=exitpos;
  835. current_settings.localswitches:=exitswitches;
  836. cg.set_regalloc_extend_backwards(false);
  837. gen_finalize_code(templist);
  838. { the finalcode must be concated if there was no position available,
  839. using insertlistafter will result in an insert at the start
  840. when currentai=nil }
  841. if assigned(final_asmnode.currenttai) then
  842. aktproccode.insertlistafter(final_asmnode.currenttai,templist)
  843. else
  844. aktproccode.concatlist(templist);
  845. { insert exit label at the correct position }
  846. cg.a_label(templist,CurrExitLabel);
  847. if assigned(exitlabel_asmnode.currenttai) then
  848. aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
  849. else
  850. aktproccode.concatlist(templist);
  851. { exit code }
  852. gen_exit_code(templist);
  853. aktproccode.concatlist(templist);
  854. {$ifdef OLDREGVARS}
  855. { note: this must be done only after as much code as possible has }
  856. { been generated. The result is that when you ungetregister() a }
  857. { regvar, it will actually free the regvar (and alse free the }
  858. { the regvars at the same time). Doing this too early will }
  859. { confuse the register allocator, as the regvars will still be }
  860. { used. It should be done before loading the result regs (so }
  861. { they don't conflict with the regvars) and before }
  862. { gen_entry_code (that one has to be able to allocate the }
  863. { regvars again) (JM) }
  864. free_regvars(aktproccode);
  865. {$endif OLDREGVARS}
  866. { generate symbol and save end of header position }
  867. current_filepos:=entrypos;
  868. gen_proc_symbol(templist);
  869. headertai:=tai(templist.last);
  870. { insert symbol }
  871. aktproccode.insertlist(templist);
  872. { Free space in temp/registers for parast and localst, must be
  873. done after gen_entry_code }
  874. current_filepos:=exitpos;
  875. gen_free_symtable(aktproccode,procdef.localst);
  876. gen_free_symtable(aktproccode,procdef.parast);
  877. { add code that will load the return value, this is not done
  878. for assembler routines when they didn't reference the result
  879. variable }
  880. gen_load_return_value(templist);
  881. aktproccode.concatlist(templist);
  882. { Already reserve all registers for stack checking code and
  883. generate the call to the helper function }
  884. if (cs_check_stack in entryswitches) and
  885. not(po_assembler in procdef.procoptions) and
  886. (procdef.proctypeoption<>potype_proginit) then
  887. begin
  888. current_filepos:=entrypos;
  889. gen_stack_check_call(templist);
  890. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  891. end;
  892. { load got if necessary }
  893. cg.set_regalloc_extend_backwards(true);
  894. current_filepos:=entrypos;
  895. gen_got_load(templist);
  896. aktproccode.insertlistafter(headertai,templist);
  897. cg.set_regalloc_extend_backwards(false);
  898. { The procedure body is finished, we can now
  899. allocate the registers }
  900. cg.do_register_allocation(aktproccode,headertai);
  901. { translate imag. register to their real counter parts
  902. this is necessary for debuginfo and verbose assembler output
  903. when SSA will be implented, this will be more complicated because we've to
  904. maintain location lists }
  905. current_procinfo.procdef.parast.SymList.ForEachCall(@translate_registers,templist);
  906. current_procinfo.procdef.localst.SymList.ForEachCall(@translate_registers,templist);
  907. { Add save and restore of used registers }
  908. current_filepos:=entrypos;
  909. gen_save_used_regs(templist);
  910. aktproccode.insertlistafter(headertai,templist);
  911. current_filepos:=exitpos;
  912. gen_restore_used_regs(aktproccode);
  913. { We know the size of the stack, now we can generate the
  914. parameter that is passed to the stack checking code }
  915. if (cs_check_stack in entryswitches) and
  916. not(po_assembler in procdef.procoptions) and
  917. (procdef.proctypeoption<>potype_proginit) then
  918. begin
  919. current_filepos:=entrypos;
  920. gen_stack_check_size_para(templist);
  921. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  922. end;
  923. { Add entry code (stack allocation) after header }
  924. current_filepos:=entrypos;
  925. gen_proc_entry_code(templist);
  926. aktproccode.insertlistafter(headertai,templist);
  927. {$if defined(x86) or defined(arm)}
  928. { Set return value of safecall procedure if implicit try/finally blocks are disabled }
  929. if not (cs_implicit_exceptions in current_settings.moduleswitches) and
  930. (procdef.proccalloption=pocall_safecall) then
  931. cg.a_load_const_reg(aktproccode,OS_ADDR,0,NR_FUNCTION_RETURN_REG);
  932. {$endif}
  933. { Add exit code at the end }
  934. current_filepos:=exitpos;
  935. gen_proc_exit_code(templist);
  936. aktproccode.concatlist(templist);
  937. { check if the implicit finally has been generated. The flag
  938. should already be set in pass1 }
  939. if (cs_implicit_exceptions in current_settings.moduleswitches) and
  940. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
  941. (pi_needs_implicit_finally in flags) and
  942. not(pi_has_implicit_finally in flags) then
  943. internalerror(200405231);
  944. {$ifndef NoOpt}
  945. if not(cs_no_regalloc in current_settings.globalswitches) then
  946. begin
  947. if (cs_opt_level1 in current_settings.optimizerswitches) and
  948. { do not optimize pure assembler procedures }
  949. not(pi_is_assembler in flags) then
  950. optimize(aktproccode);
  951. end;
  952. {$endif NoOpt}
  953. {$ifdef ARM}
  954. { because of the limited constant size of the arm, all data access is done pc relative }
  955. insertpcrelativedata(aktproccode,aktlocaldata);
  956. {$endif ARM}
  957. { Add end symbol and debug info }
  958. { this must be done after the pcrelativedata is appended else the distance calculation of
  959. insertpcrelativedata will be wrong, further the pc indirect data is part of the procedure
  960. so it should be inserted before the end symbol (FK)
  961. }
  962. current_filepos:=exitpos;
  963. gen_proc_symbol_end(templist);
  964. aktproccode.concatlist(templist);
  965. {$if defined(POWERPC) or defined(POWERPC64)}
  966. fixup_jmps(aktproccode);
  967. {$endif}
  968. { insert line debuginfo }
  969. if (cs_debuginfo in current_settings.moduleswitches) or
  970. (cs_use_lineinfo in current_settings.globalswitches) then
  971. debuginfo.insertlineinfo(aktproccode);
  972. { add the procedure to the al_procedures }
  973. maybe_new_object_file(current_asmdata.asmlists[al_procedures]);
  974. new_section(current_asmdata.asmlists[al_procedures],sec_code,lower(procdef.mangledname),getprocalign);
  975. current_asmdata.asmlists[al_procedures].concatlist(aktproccode);
  976. { save local data (casetable) also in the same file }
  977. if assigned(aktlocaldata) and
  978. (not aktlocaldata.empty) then
  979. current_asmdata.asmlists[al_procedures].concatlist(aktlocaldata);
  980. { only now we can remove the temps }
  981. tg.resettempgen;
  982. { stop tempgen and ra }
  983. tg.free;
  984. cg.done_register_allocators;
  985. tg:=nil;
  986. end;
  987. { restore symtablestack }
  988. remove_from_symtablestack;
  989. { restore }
  990. templist.free;
  991. current_settings.maxfpuregisters:=oldmaxfpuregisters;
  992. current_filepos:=oldfilepos;
  993. current_procinfo:=oldprocinfo;
  994. end;
  995. procedure tcgprocinfo.add_to_symtablestack;
  996. var
  997. _class,hp : tobjectdef;
  998. begin
  999. { insert symtables for the class, but only if it is no nested function }
  1000. if assigned(procdef._class) and
  1001. not(assigned(parent) and
  1002. assigned(parent.procdef) and
  1003. assigned(parent.procdef._class)) then
  1004. begin
  1005. { insert them in the reverse order }
  1006. hp:=nil;
  1007. repeat
  1008. _class:=procdef._class;
  1009. while _class.childof<>hp do
  1010. _class:=_class.childof;
  1011. hp:=_class;
  1012. symtablestack.push(_class.symtable);
  1013. until hp=procdef._class;
  1014. end;
  1015. { insert parasymtable in symtablestack when parsing
  1016. a function }
  1017. if procdef.parast.symtablelevel>=normal_function_level then
  1018. symtablestack.push(procdef.parast);
  1019. { insert localsymtable }
  1020. symtablestack.push(procdef.localst);
  1021. end;
  1022. procedure tcgprocinfo.remove_from_symtablestack;
  1023. var
  1024. _class : tobjectdef;
  1025. begin
  1026. { remove localsymtable }
  1027. symtablestack.pop(procdef.localst);
  1028. { remove parasymtable }
  1029. if procdef.parast.symtablelevel>=normal_function_level then
  1030. symtablestack.pop(procdef.parast);
  1031. { remove symtables for the class, but only if it is no nested function }
  1032. if assigned(procdef._class) and
  1033. not(assigned(parent) and
  1034. assigned(parent.procdef) and
  1035. assigned(parent.procdef._class)) then
  1036. begin
  1037. _class:=procdef._class;
  1038. while assigned(_class) do
  1039. begin
  1040. symtablestack.pop(_class.symtable);
  1041. _class:=_class.childof;
  1042. end;
  1043. end;
  1044. end;
  1045. procedure tcgprocinfo.resetprocdef;
  1046. begin
  1047. { remove code tree, if not inline procedure }
  1048. if assigned(code) then
  1049. begin
  1050. { the inline procedure has already got a copy of the tree
  1051. stored in procdef.inlininginfo }
  1052. code.free;
  1053. code:=nil;
  1054. end;
  1055. end;
  1056. function checknodeinlining(procdef: tprocdef): boolean;
  1057. var
  1058. i : integer;
  1059. currpara : tparavarsym;
  1060. begin
  1061. result := false;
  1062. if (pi_has_assembler_block in current_procinfo.flags) then
  1063. exit;
  1064. for i:=0 to procdef.paras.count-1 do
  1065. begin
  1066. currpara:=tparavarsym(procdef.paras[i]);
  1067. { we can't handle formaldefs and special arrays (the latter may need a }
  1068. { re-basing of the index, i.e. if you pass an array[1..10] as open array, }
  1069. { you have to add 1 to all index operations if you directly inline it }
  1070. if ((currpara.varspez in [vs_out,vs_var,vs_const]) and
  1071. (currpara.vardef.typ=formaldef)) or
  1072. is_special_array(currpara.vardef) then
  1073. exit;
  1074. end;
  1075. result:=true;
  1076. end;
  1077. procedure tcgprocinfo.parse_body;
  1078. var
  1079. oldprocinfo : tprocinfo;
  1080. oldblock_type : tblock_type;
  1081. st : TSymtable;
  1082. begin
  1083. oldprocinfo:=current_procinfo;
  1084. oldblock_type:=block_type;
  1085. { reset break and continue labels }
  1086. block_type:=bt_body;
  1087. current_procinfo:=self;
  1088. { calculate the lexical level }
  1089. if procdef.parast.symtablelevel>maxnesting then
  1090. Message(parser_e_too_much_lexlevel);
  1091. {$ifdef state_tracking}
  1092. { aktstate:=Tstate_storage.create;}
  1093. {$endif state_tracking}
  1094. { allocate the symbol for this procedure }
  1095. alloc_proc_symbol(procdef);
  1096. { add parast/localst to symtablestack }
  1097. add_to_symtablestack;
  1098. { save entry info }
  1099. entrypos:=current_filepos;
  1100. entryswitches:=current_settings.localswitches;
  1101. if (df_generic in procdef.defoptions) then
  1102. begin
  1103. { start token recorder for generic template }
  1104. procdef.initgeneric;
  1105. current_scanner.startrecordtokens(procdef.generictokenbuf);
  1106. end;
  1107. { parse the code ... }
  1108. code:=block(current_module.islibrary);
  1109. if (df_generic in procdef.defoptions) then
  1110. begin
  1111. { stop token recorder for generic template }
  1112. current_scanner.stoprecordtokens;
  1113. { Give a warning for accesses in the static symtable that aren't visible
  1114. outside the current unit }
  1115. st:=procdef.owner;
  1116. while (st.symtabletype=ObjectSymtable) do
  1117. st:=st.defowner.owner;
  1118. if (pi_uses_static_symtable in flags) and
  1119. (st.symtabletype<>staticsymtable) then
  1120. Comment(V_Warning,'Global Generic template references static symtable');
  1121. end;
  1122. { save exit info }
  1123. exitswitches:=current_settings.localswitches;
  1124. exitpos:=last_endtoken_filepos;
  1125. { the procedure is now defined }
  1126. procdef.forwarddef:=false;
  1127. if assigned(code) then
  1128. begin
  1129. { get a better entry point }
  1130. entrypos:=code.fileinfo;
  1131. { Finish type checking pass }
  1132. do_typecheckpass(code);
  1133. end;
  1134. { Check for unused labels, forwards, symbols for procedures. Static
  1135. symtable is checked in pmodules.
  1136. The check must be done after the typecheckpass }
  1137. if (Errorcount=0) and
  1138. (tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then
  1139. begin
  1140. { check if forwards are resolved }
  1141. tstoredsymtable(procdef.localst).check_forwards;
  1142. { check if all labels are used }
  1143. tstoredsymtable(procdef.localst).checklabels;
  1144. { remove cross unit overloads }
  1145. tstoredsymtable(procdef.localst).unchain_overloaded;
  1146. { check for unused symbols, but only if there is no asm block }
  1147. if not(pi_has_assembler_block in flags) then
  1148. begin
  1149. tstoredsymtable(procdef.localst).allsymbolsused;
  1150. tstoredsymtable(procdef.parast).allsymbolsused;
  1151. end;
  1152. end;
  1153. if (po_inline in procdef.procoptions) then
  1154. begin
  1155. { Can we inline this procedure? }
  1156. if checknodeinlining(procdef) then
  1157. begin
  1158. new(procdef.inlininginfo);
  1159. include(procdef.procoptions,po_has_inlininginfo);
  1160. procdef.inlininginfo^.code:=code.getcopy;
  1161. procdef.inlininginfo^.flags:=current_procinfo.flags;
  1162. { The blocknode needs to set an exit label }
  1163. if procdef.inlininginfo^.code.nodetype=blockn then
  1164. include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
  1165. end;
  1166. end;
  1167. { Print the node to tree.log }
  1168. if paraprintnodetree=1 then
  1169. printproc;
  1170. { ... remove symbol tables }
  1171. remove_from_symtablestack;
  1172. {$ifdef state_tracking}
  1173. { aktstate.destroy;}
  1174. {$endif state_tracking}
  1175. current_procinfo:=oldprocinfo;
  1176. { Restore old state }
  1177. block_type:=oldblock_type;
  1178. end;
  1179. {****************************************************************************
  1180. PROCEDURE/FUNCTION PARSING
  1181. ****************************************************************************}
  1182. procedure check_init_paras(p:TObject;arg:pointer);
  1183. begin
  1184. if tsym(p).typ<>paravarsym then
  1185. exit;
  1186. with tparavarsym(p) do
  1187. if (not is_class(vardef) and
  1188. vardef.needs_inittable and
  1189. (varspez in [vs_value,vs_out])) then
  1190. include(current_procinfo.flags,pi_do_call);
  1191. end;
  1192. procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
  1193. {
  1194. Parses the procedure directives, then parses the procedure body, then
  1195. generates the code for it
  1196. }
  1197. procedure do_generate_code(pi:tcgprocinfo);
  1198. var
  1199. hpi : tcgprocinfo;
  1200. begin
  1201. { generate code for this procedure }
  1202. pi.generate_code;
  1203. { process nested procs }
  1204. hpi:=tcgprocinfo(pi.nestedprocs.first);
  1205. while assigned(hpi) do
  1206. begin
  1207. do_generate_code(hpi);
  1208. hpi:=tcgprocinfo(hpi.next);
  1209. end;
  1210. pi.resetprocdef;
  1211. end;
  1212. var
  1213. oldfailtokenmode : tmodeswitch;
  1214. isnestedproc : boolean;
  1215. begin
  1216. Message1(parser_d_procedure_start,pd.fullprocname(false));
  1217. { create a new procedure }
  1218. current_procinfo:=cprocinfo.create(old_current_procinfo);
  1219. current_module.procinfo:=current_procinfo;
  1220. current_procinfo.procdef:=pd;
  1221. isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
  1222. { Insert mangledname }
  1223. pd.aliasnames.insert(pd.mangledname);
  1224. { Handle Export of this procedure }
  1225. if (po_exports in pd.procoptions) and
  1226. (target_info.system in [system_i386_os2,system_i386_emx]) then
  1227. begin
  1228. pd.aliasnames.insert(pd.procsym.realname);
  1229. if cs_link_deffile in current_settings.globalswitches then
  1230. deffile.AddExport(pd.mangledname);
  1231. end;
  1232. { Insert result variables in the localst }
  1233. insert_funcret_local(pd);
  1234. { check if there are para's which require initing -> set }
  1235. { pi_do_call (if not yet set) }
  1236. if not(pi_do_call in current_procinfo.flags) then
  1237. pd.parast.SymList.ForEachCall(@check_init_paras,nil);
  1238. { set _FAIL as keyword if constructor }
  1239. if (pd.proctypeoption=potype_constructor) then
  1240. begin
  1241. oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
  1242. tokeninfo^[_FAIL].keyword:=m_all;
  1243. end;
  1244. tcgprocinfo(current_procinfo).parse_body;
  1245. { When it's a nested procedure then defer the code generation,
  1246. when back at normal function level then generate the code
  1247. for all defered nested procedures and the current procedure }
  1248. if isnestedproc then
  1249. tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
  1250. else
  1251. begin
  1252. { We can't support inlining for procedures that have nested
  1253. procedures because the nested procedures use a fixed offset
  1254. for accessing locals in the parent procedure (PFV) }
  1255. if (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
  1256. begin
  1257. if (df_generic in current_procinfo.procdef.defoptions) then
  1258. Comment(V_Error,'Generic methods cannot have nested procedures')
  1259. else
  1260. if (po_inline in current_procinfo.procdef.procoptions) then
  1261. begin
  1262. Message1(parser_w_not_supported_for_inline,'nested procedures');
  1263. Message(parser_w_inlining_disabled);
  1264. current_procinfo.procdef.proccalloption:=pocall_default;
  1265. end;
  1266. end;
  1267. if not(df_generic in current_procinfo.procdef.defoptions) then
  1268. do_generate_code(tcgprocinfo(current_procinfo));
  1269. end;
  1270. { reset _FAIL as _SELF normal }
  1271. if (pd.proctypeoption=potype_constructor) then
  1272. tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
  1273. { release procinfo }
  1274. if tprocinfo(current_module.procinfo)<>current_procinfo then
  1275. internalerror(200304274);
  1276. current_module.procinfo:=current_procinfo.parent;
  1277. { For specialization we didn't record the last semicolon. Moving this parsing
  1278. into the parse_body routine is not done because of having better file position
  1279. information available }
  1280. if not(df_specialization in current_procinfo.procdef.defoptions) then
  1281. consume(_SEMICOLON);
  1282. if not isnestedproc then
  1283. { current_procinfo is checked for nil later on }
  1284. freeandnil(current_procinfo);
  1285. end;
  1286. procedure read_proc;
  1287. {
  1288. Parses the procedure directives, then parses the procedure body, then
  1289. generates the code for it
  1290. }
  1291. procedure do_generate_code(pi:tcgprocinfo);
  1292. var
  1293. hpi : tcgprocinfo;
  1294. begin
  1295. { generate code for this procedure }
  1296. pi.generate_code;
  1297. { process nested procs }
  1298. hpi:=tcgprocinfo(pi.nestedprocs.first);
  1299. while assigned(hpi) do
  1300. begin
  1301. do_generate_code(hpi);
  1302. hpi:=tcgprocinfo(hpi.next);
  1303. end;
  1304. pi.resetprocdef;
  1305. end;
  1306. var
  1307. old_current_procinfo : tprocinfo;
  1308. pdflags : tpdflags;
  1309. pd,firstpd : tprocdef;
  1310. s : string;
  1311. begin
  1312. { save old state }
  1313. old_current_procinfo:=current_procinfo;
  1314. { reset current_procinfo.procdef to nil to be sure that nothing is writing
  1315. to an other procdef }
  1316. current_procinfo:=nil;
  1317. { parse procedure declaration }
  1318. if assigned(old_current_procinfo) and
  1319. assigned(old_current_procinfo.procdef) then
  1320. pd:=parse_proc_dec(old_current_procinfo.procdef._class)
  1321. else
  1322. pd:=parse_proc_dec(nil);
  1323. { set the default function options }
  1324. if parse_only then
  1325. begin
  1326. pd.forwarddef:=true;
  1327. { set also the interface flag, for better error message when the
  1328. implementation doesn't much this header }
  1329. pd.interfacedef:=true;
  1330. include(pd.procoptions,po_global);
  1331. pdflags:=[pd_interface];
  1332. end
  1333. else
  1334. begin
  1335. pdflags:=[pd_body];
  1336. if (not current_module.in_interface) then
  1337. include(pdflags,pd_implemen);
  1338. if (not current_module.is_unit) or
  1339. maybe_smartlink_symbol or
  1340. {
  1341. taking addresses of static procedures goes wrong
  1342. if they aren't global when pic is used (FK)
  1343. }
  1344. (cs_create_pic in current_settings.moduleswitches) then
  1345. include(pd.procoptions,po_global);
  1346. pd.forwarddef:=false;
  1347. end;
  1348. { parse the directives that may follow }
  1349. parse_proc_directives(pd,pdflags);
  1350. { hint directives, these can be separated by semicolons here,
  1351. that needs to be handled here with a loop (PFV) }
  1352. while try_consume_hintdirective(pd.symoptions) do
  1353. Consume(_SEMICOLON);
  1354. { Set calling convention }
  1355. handle_calling_convention(pd);
  1356. { search for forward declarations }
  1357. if not proc_add_definition(pd) then
  1358. begin
  1359. { A method must be forward defined (in the object declaration) }
  1360. if assigned(pd._class) and
  1361. (not assigned(old_current_procinfo.procdef._class)) then
  1362. begin
  1363. MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false));
  1364. tprocsym(pd.procsym).write_parameter_lists(pd);
  1365. end
  1366. else
  1367. begin
  1368. { Give a better error if there is a forward def in the interface and only
  1369. a single implementation }
  1370. firstpd:=tprocdef(tprocsym(pd.procsym).ProcdefList[0]);
  1371. if (not pd.forwarddef) and
  1372. (not pd.interfacedef) and
  1373. (tprocsym(pd.procsym).ProcdefList.Count>1) and
  1374. firstpd.forwarddef and
  1375. firstpd.interfacedef and
  1376. not(tprocsym(pd.procsym).ProcdefList.Count>2) and
  1377. { don't give an error if it may be an overload }
  1378. not(m_fpc in current_settings.modeswitches) and
  1379. (not(po_overload in pd.procoptions) or
  1380. not(po_overload in firstpd.procoptions)) then
  1381. begin
  1382. MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
  1383. tprocsym(pd.procsym).write_parameter_lists(pd);
  1384. end;
  1385. end;
  1386. end;
  1387. { Set mangled name }
  1388. proc_set_mangledname(pd);
  1389. { compile procedure when a body is needed }
  1390. if (pd_body in pdflags) then
  1391. begin
  1392. read_proc_body(old_current_procinfo,pd);
  1393. end
  1394. else
  1395. begin
  1396. { Handle imports }
  1397. if (po_external in pd.procoptions) then
  1398. begin
  1399. { External declared in implementation, and there was already a
  1400. forward (or interface) declaration then we need to generate
  1401. a stub that calls the external routine }
  1402. if (not pd.forwarddef) and
  1403. (pd.hasforward) and
  1404. not(
  1405. assigned(pd.import_dll) and
  1406. (target_info.system in [system_i386_wdosx,
  1407. system_arm_wince,system_i386_wince])
  1408. ) then
  1409. begin
  1410. s:=proc_get_importname(pd);
  1411. if s<>'' then
  1412. gen_external_stub(current_asmdata.asmlists[al_procedures],pd,{$IFDEF POWERPC64}'.'+{$ENDIF}s);
  1413. end;
  1414. { Import DLL specified? }
  1415. if assigned(pd.import_dll) then
  1416. current_module.AddExternalImport(pd.import_dll^,proc_get_importname(pd),pd.import_nr,false)
  1417. else
  1418. begin
  1419. { add import name to external list for DLL scanning }
  1420. if tf_has_dllscanner in target_info.flags then
  1421. current_module.dllscannerinputlist.Add(proc_get_importname(pd),pd);
  1422. end;
  1423. end;
  1424. end;
  1425. { make sure that references to forward-declared functions are not }
  1426. { treated as references to external symbols, needed for darwin. }
  1427. { make sure we don't change the binding of real external symbols }
  1428. if not(po_external in pd.procoptions) then
  1429. begin
  1430. if (po_global in pd.procoptions) or
  1431. (cs_profile in current_settings.moduleswitches) then
  1432. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_GLOBAL,AT_FUNCTION)
  1433. else
  1434. current_asmdata.DefineAsmSymbol(pd.mangledname,AB_LOCAL,AT_FUNCTION);
  1435. end;
  1436. current_procinfo:=old_current_procinfo;
  1437. end;
  1438. {****************************************************************************
  1439. DECLARATION PARSING
  1440. ****************************************************************************}
  1441. { search in symtablestack for not complete classes }
  1442. procedure check_forward_class(p:TObject;arg:pointer);
  1443. begin
  1444. if (tsym(p).typ=typesym) and
  1445. (ttypesym(p).typedef.typ=objectdef) and
  1446. (oo_is_forward in tobjectdef(ttypesym(p).typedef).objectoptions) then
  1447. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  1448. end;
  1449. procedure read_declarations(islibrary : boolean);
  1450. begin
  1451. repeat
  1452. if not assigned(current_procinfo) then
  1453. internalerror(200304251);
  1454. case token of
  1455. _LABEL:
  1456. label_dec;
  1457. _CONST:
  1458. const_dec;
  1459. _TYPE:
  1460. type_dec;
  1461. _VAR:
  1462. var_dec;
  1463. _THREADVAR:
  1464. threadvar_dec;
  1465. _CONSTRUCTOR,
  1466. _DESTRUCTOR,
  1467. _FUNCTION,
  1468. _PROCEDURE,
  1469. _OPERATOR,
  1470. _CLASS:
  1471. read_proc;
  1472. _EXPORTS:
  1473. begin
  1474. if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
  1475. begin
  1476. Message(parser_e_syntax_error);
  1477. consume_all_until(_SEMICOLON);
  1478. end
  1479. else if islibrary or
  1480. (target_info.system in system_unit_program_exports) then
  1481. read_exports
  1482. else
  1483. begin
  1484. Message(parser_w_unsupported_feature);
  1485. consume(_BEGIN);
  1486. end;
  1487. end
  1488. else
  1489. begin
  1490. case idtoken of
  1491. _RESOURCESTRING :
  1492. begin
  1493. { m_class is needed, because the resourcestring
  1494. loading is in the ObjPas unit }
  1495. { if (m_class in current_settings.modeswitches) then}
  1496. resourcestring_dec
  1497. { else
  1498. break;}
  1499. end;
  1500. _PROPERTY:
  1501. begin
  1502. if (m_fpc in current_settings.modeswitches) then
  1503. property_dec
  1504. else
  1505. break;
  1506. end;
  1507. else
  1508. break;
  1509. end;
  1510. end;
  1511. end;
  1512. until false;
  1513. { check for incomplete class definitions, this is only required
  1514. for fpc modes }
  1515. if (m_fpc in current_settings.modeswitches) then
  1516. current_procinfo.procdef.localst.SymList.ForEachCall(@check_forward_class,nil);
  1517. end;
  1518. procedure read_interface_declarations;
  1519. begin
  1520. repeat
  1521. case token of
  1522. _CONST :
  1523. const_dec;
  1524. _TYPE :
  1525. type_dec;
  1526. _VAR :
  1527. var_dec;
  1528. _THREADVAR :
  1529. threadvar_dec;
  1530. _FUNCTION,
  1531. _PROCEDURE,
  1532. _OPERATOR :
  1533. read_proc;
  1534. else
  1535. begin
  1536. case idtoken of
  1537. _RESOURCESTRING :
  1538. resourcestring_dec;
  1539. _PROPERTY:
  1540. begin
  1541. if (m_fpc in current_settings.modeswitches) then
  1542. property_dec
  1543. else
  1544. break;
  1545. end;
  1546. else
  1547. break;
  1548. end;
  1549. end;
  1550. end;
  1551. until false;
  1552. { check for incomplete class definitions, this is only required
  1553. for fpc modes }
  1554. if (m_fpc in current_settings.modeswitches) then
  1555. symtablestack.top.SymList.ForEachCall(@check_forward_class,nil);
  1556. end;
  1557. {****************************************************************************
  1558. SPECIALIZATION BODY GENERATION
  1559. ****************************************************************************}
  1560. procedure specialize_objectdefs(p:TObject;arg:pointer);
  1561. function find_module_from_symtable(st:tsymtable):tmodule;
  1562. var
  1563. hp : tmodule;
  1564. begin
  1565. result:=nil;
  1566. hp:=tmodule(loaded_units.first);
  1567. while assigned(hp) do
  1568. begin
  1569. if (hp.globalsymtable=st) or
  1570. (hp.localsymtable=st) then
  1571. begin
  1572. result:=hp;
  1573. exit;
  1574. end;
  1575. hp:=tmodule(hp.next);
  1576. end;
  1577. end;
  1578. var
  1579. i : longint;
  1580. hp : tdef;
  1581. oldcurrent_filepos : tfileposinfo;
  1582. oldsymtablestack : tsymtablestack;
  1583. pu : tused_unit;
  1584. hmodule : tmodule;
  1585. begin
  1586. if not((tsym(p).typ=typesym) and
  1587. (ttypesym(p).typedef.typ=objectdef) and
  1588. (df_specialization in ttypesym(p).typedef.defoptions)
  1589. ) then
  1590. exit;
  1591. { Setup symtablestack a definition time }
  1592. oldsymtablestack:=symtablestack;
  1593. symtablestack:=tsymtablestack.create;
  1594. if not assigned(tobjectdef(ttypesym(p).typedef).genericdef) then
  1595. internalerror(200705151);
  1596. hmodule:=find_module_from_symtable(tobjectdef(ttypesym(p).typedef).genericdef.owner);
  1597. if hmodule=nil then
  1598. internalerror(200705152);
  1599. pu:=tused_unit(hmodule.used_units.first);
  1600. while assigned(pu) do
  1601. begin
  1602. if not assigned(pu.u.globalsymtable) then
  1603. internalerror(200705153);
  1604. symtablestack.push(pu.u.globalsymtable);
  1605. pu:=tused_unit(pu.next);
  1606. end;
  1607. symtablestack.push(hmodule.globalsymtable);
  1608. symtablestack.push(hmodule.localsymtable);
  1609. { definitions }
  1610. for i:=0 to tobjectdef(ttypesym(p).typedef).symtable.DefList.Count-1 do
  1611. begin
  1612. hp:=tdef(tobjectdef(ttypesym(p).typedef).symtable.DefList[i]);
  1613. if hp.typ=procdef then
  1614. begin
  1615. if assigned(tprocdef(hp).genericdef) and
  1616. (tprocdef(hp).genericdef.typ=procdef) and
  1617. assigned(tprocdef(tprocdef(hp).genericdef).generictokenbuf) then
  1618. begin
  1619. oldcurrent_filepos:=current_filepos;
  1620. current_filepos:=tprocdef(tprocdef(hp).genericdef).fileinfo;
  1621. current_tokenpos:=current_filepos;
  1622. current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf);
  1623. read_proc_body(nil,tprocdef(hp));
  1624. current_filepos:=oldcurrent_filepos;
  1625. end
  1626. else
  1627. MessagePos1(tprocdef(tprocdef(hp).genericdef).fileinfo,sym_e_forward_not_resolved,tprocdef(tprocdef(hp).genericdef).fullprocname(false));
  1628. end;
  1629. end;
  1630. { Restore symtablestack }
  1631. symtablestack.free;
  1632. symtablestack:=oldsymtablestack;
  1633. end;
  1634. procedure generate_specialization_procs;
  1635. begin
  1636. if assigned(current_module.globalsymtable) then
  1637. current_module.globalsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
  1638. if assigned(current_module.localsymtable) then
  1639. current_module.localsymtable.SymList.ForEachCall(@specialize_objectdefs,nil);
  1640. end;
  1641. end.