psub.pas 60 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl, Daniel Mantione
  4. Does the parsing and codegeneration at subroutine level
  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 psub;
  19. {$i fpcdefs.inc}
  20. interface
  21. uses
  22. cclasses,globals,
  23. node,nbas,
  24. symdef,procinfo;
  25. type
  26. tcgprocinfo = class(tprocinfo)
  27. private
  28. procedure add_entry_exit_code;
  29. public
  30. { code for the subroutine as tree }
  31. code : tnode;
  32. { positions in the tree for init/final }
  33. entry_asmnode,
  34. loadpara_asmnode,
  35. exitlabel_asmnode,
  36. stackcheck_asmnode,
  37. init_asmnode,
  38. final_asmnode : tasmnode;
  39. { list to store the procinfo's of the nested procedures }
  40. nestedprocs : tlinkedlist;
  41. constructor create(aparent:tprocinfo);override;
  42. destructor destroy;override;
  43. procedure printproc;
  44. procedure generate_code;
  45. procedure resetprocdef;
  46. procedure add_to_symtablestack;
  47. procedure remove_from_symtablestack;
  48. procedure parse_body;
  49. end;
  50. procedure printnode_reset;
  51. { reads the declaration blocks }
  52. procedure read_declarations(islibrary : boolean);
  53. { reads declarations in the interface part of a unit }
  54. procedure read_interface_declarations;
  55. implementation
  56. uses
  57. { common }
  58. cutils,
  59. { global }
  60. globtype,tokens,verbose,comphook,
  61. systems,
  62. { aasm }
  63. cpubase,aasmbase,aasmtai,
  64. { symtable }
  65. symconst,symbase,symsym,symtype,symtable,defutil,
  66. paramgr,
  67. ppu,fmodule,
  68. { pass 1 }
  69. nutils,nld,ncal,ncon,nflw,nadd,ncnv,nmem,
  70. pass_1,
  71. {$ifdef state_tracking}
  72. nstate,
  73. {$endif state_tracking}
  74. { pass 2 }
  75. {$ifndef NOPASS2}
  76. pass_2,
  77. {$endif}
  78. { parser }
  79. scanner,import,gendef,
  80. pbase,pstatmnt,pdecl,pdecsub,pexports,
  81. { codegen }
  82. tgobj,cgobj,
  83. ncgutil,regvars
  84. {$ifdef arm}
  85. ,aasmcpu
  86. {$endif arm}
  87. {$ifndef NOOPT}
  88. {$ifdef i386}
  89. ,aopt386
  90. {$else i386}
  91. ,aopt
  92. {$endif i386}
  93. {$endif}
  94. ;
  95. {****************************************************************************
  96. PROCEDURE/FUNCTION BODY PARSING
  97. ****************************************************************************}
  98. procedure initializevars(p:tnamedindexitem;arg:pointer);
  99. var
  100. b : tblocknode;
  101. begin
  102. if not (tsym(p).typ in [localvarsym,globalvarsym]) then
  103. exit;
  104. with tabstractnormalvarsym(p) do
  105. begin
  106. if assigned(defaultconstsym) then
  107. begin
  108. b:=tblocknode(arg);
  109. b.left:=cstatementnode.create(
  110. cassignmentnode.create(
  111. cloadnode.create(tsym(p),tsym(p).owner),
  112. cloadnode.create(defaultconstsym,defaultconstsym.owner)),
  113. b.left);
  114. end;
  115. end;
  116. end;
  117. procedure check_finalize_paras(p : tnamedindexitem;arg:pointer);
  118. begin
  119. if (tsym(p).typ=paravarsym) and
  120. (tparavarsym(p).varspez=vs_value) and
  121. not is_class(tparavarsym(p).vartype.def) and
  122. tparavarsym(p).vartype.def.needs_inittable then
  123. include(current_procinfo.flags,pi_needs_implicit_finally);
  124. end;
  125. procedure check_finalize_locals(p : tnamedindexitem;arg:pointer);
  126. begin
  127. if (tsym(p).typ=localvarsym) and
  128. (tlocalvarsym(p).refs>0) and
  129. not(vo_is_funcret in tlocalvarsym(p).varoptions) and
  130. not(is_class(tlocalvarsym(p).vartype.def)) and
  131. tlocalvarsym(p).vartype.def.needs_inittable then
  132. include(current_procinfo.flags,pi_needs_implicit_finally);
  133. end;
  134. function block(islibrary : boolean) : tnode;
  135. begin
  136. { parse const,types and vars }
  137. read_declarations(islibrary);
  138. { do we have an assembler block without the po_assembler?
  139. we should allow this for Delphi compatibility (PFV) }
  140. if (token=_ASM) and (m_delphi in aktmodeswitches) then
  141. include(current_procinfo.procdef.procoptions,po_assembler);
  142. { Handle assembler block different }
  143. if (po_assembler in current_procinfo.procdef.procoptions) then
  144. begin
  145. block:=assembler_block;
  146. exit;
  147. end;
  148. {Unit initialization?.}
  149. if (
  150. assigned(current_procinfo.procdef.localst) and
  151. (current_procinfo.procdef.localst.symtablelevel=main_program_level) and
  152. (current_module.is_unit)
  153. ) or
  154. islibrary then
  155. begin
  156. if (token=_END) then
  157. begin
  158. consume(_END);
  159. { We need at least a node, else the entry/exit code is not
  160. generated and thus no PASCALMAIN symbol which we need (PFV) }
  161. if islibrary then
  162. block:=cnothingnode.create
  163. else
  164. block:=nil;
  165. end
  166. else
  167. begin
  168. if token=_INITIALIZATION then
  169. begin
  170. { The library init code is already called and does not
  171. need to be in the initfinal table (PFV) }
  172. if not islibrary then
  173. current_module.flags:=current_module.flags or uf_init;
  174. block:=statement_block(_INITIALIZATION);
  175. end
  176. else if (token=_FINALIZATION) then
  177. begin
  178. if (current_module.flags and uf_finalize)<>0 then
  179. block:=statement_block(_FINALIZATION)
  180. else
  181. begin
  182. { can we allow no INITIALIZATION for DLL ??
  183. I think it should work PM }
  184. block:=nil;
  185. exit;
  186. end;
  187. end
  188. else
  189. begin
  190. { The library init code is already called and does not
  191. need to be in the initfinal table (PFV) }
  192. if not islibrary then
  193. current_module.flags:=current_module.flags or uf_init;
  194. block:=statement_block(_BEGIN);
  195. end;
  196. end;
  197. end
  198. else
  199. begin
  200. block:=statement_block(_BEGIN);
  201. if symtablestack.symtabletype=localsymtable then
  202. symtablestack.foreach_static(@initializevars,block);
  203. end;
  204. end;
  205. {****************************************************************************
  206. PROCEDURE/FUNCTION COMPILING
  207. ****************************************************************************}
  208. procedure printnode_reset;
  209. begin
  210. assign(printnodefile,treelogfilename);
  211. {$I-}
  212. rewrite(printnodefile);
  213. {$I+}
  214. if ioresult<>0 then
  215. begin
  216. Comment(V_Error,'Error creating '+treelogfilename);
  217. exit;
  218. end;
  219. close(printnodefile);
  220. end;
  221. function generate_bodyentry_block:tnode;
  222. var
  223. srsym : tsym;
  224. para : tcallparanode;
  225. newstatement : tstatementnode;
  226. htype : ttype;
  227. begin
  228. result:=internalstatements(newstatement);
  229. if assigned(current_procinfo.procdef._class) then
  230. begin
  231. { a constructor needs a help procedure }
  232. if (current_procinfo.procdef.proctypeoption=potype_constructor) then
  233. begin
  234. if is_class(current_procinfo.procdef._class) then
  235. begin
  236. include(current_procinfo.flags,pi_needs_implicit_finally);
  237. srsym:=search_class_member(current_procinfo.procdef._class,'NEWINSTANCE');
  238. if assigned(srsym) and
  239. (srsym.typ=procsym) then
  240. begin
  241. { if vmt>1 then newinstance }
  242. addstatement(newstatement,cifnode.create(
  243. caddnode.create(gtn,
  244. ctypeconvnode.create_internal(
  245. load_vmt_pointer_node,
  246. voidpointertype),
  247. cpointerconstnode.create(1,voidpointertype)),
  248. cassignmentnode.create(
  249. ctypeconvnode.create_internal(
  250. load_self_pointer_node,
  251. voidpointertype),
  252. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_vmt_pointer_node,[])),
  253. nil));
  254. end
  255. else
  256. internalerror(200305108);
  257. end
  258. else
  259. if is_object(current_procinfo.procdef._class) then
  260. begin
  261. htype.setdef(current_procinfo.procdef._class);
  262. htype.setdef(tpointerdef.create(htype));
  263. { parameter 3 : vmt_offset }
  264. { parameter 2 : address of pointer to vmt,
  265. this is required to allow setting the vmt to -1 to indicate
  266. that memory was allocated }
  267. { parameter 1 : self pointer }
  268. para:=ccallparanode.create(
  269. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  270. ccallparanode.create(
  271. ctypeconvnode.create_internal(
  272. load_vmt_pointer_node,
  273. voidpointertype),
  274. ccallparanode.create(
  275. ctypeconvnode.create_internal(
  276. load_self_pointer_node,
  277. voidpointertype),
  278. nil)));
  279. addstatement(newstatement,cassignmentnode.create(
  280. ctypeconvnode.create_internal(
  281. load_self_pointer_node,
  282. voidpointertype),
  283. ccallnode.createintern('fpc_help_constructor',para)));
  284. end
  285. else
  286. internalerror(200305103);
  287. { if self=nil then exit
  288. calling fail instead of exit is useless because
  289. there is nothing to dispose (PFV) }
  290. addstatement(newstatement,cifnode.create(
  291. caddnode.create(equaln,
  292. load_self_pointer_node,
  293. cnilnode.create),
  294. cexitnode.create(nil),
  295. nil));
  296. end;
  297. { maybe call BeforeDestruction for classes }
  298. if (current_procinfo.procdef.proctypeoption=potype_destructor) and
  299. is_class(current_procinfo.procdef._class) then
  300. begin
  301. srsym:=search_class_member(current_procinfo.procdef._class,'BEFOREDESTRUCTION');
  302. if assigned(srsym) and
  303. (srsym.typ=procsym) then
  304. begin
  305. { if vmt<>0 then beforedestruction }
  306. addstatement(newstatement,cifnode.create(
  307. caddnode.create(unequaln,
  308. load_vmt_pointer_node,
  309. cnilnode.create),
  310. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  311. nil));
  312. end
  313. else
  314. internalerror(200305104);
  315. end;
  316. end;
  317. end;
  318. function generate_bodyexit_block:tnode;
  319. var
  320. srsym : tsym;
  321. para : tcallparanode;
  322. newstatement : tstatementnode;
  323. begin
  324. result:=internalstatements(newstatement);
  325. if assigned(current_procinfo.procdef._class) then
  326. begin
  327. { maybe call AfterConstruction for classes }
  328. if (current_procinfo.procdef.proctypeoption=potype_constructor) and
  329. is_class(current_procinfo.procdef._class) then
  330. begin
  331. srsym:=search_class_member(current_procinfo.procdef._class,'AFTERCONSTRUCTION');
  332. if assigned(srsym) and
  333. (srsym.typ=procsym) then
  334. begin
  335. { Self can be nil when fail is called }
  336. { if self<>nil and vmt<>nil then afterconstruction }
  337. addstatement(newstatement,cifnode.create(
  338. caddnode.create(andn,
  339. caddnode.create(unequaln,
  340. load_self_pointer_node,
  341. cnilnode.create),
  342. caddnode.create(unequaln,
  343. load_vmt_pointer_node,
  344. cnilnode.create)),
  345. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  346. nil));
  347. end
  348. else
  349. internalerror(200305106);
  350. end;
  351. { a destructor needs a help procedure }
  352. if (current_procinfo.procdef.proctypeoption=potype_destructor) then
  353. begin
  354. if is_class(current_procinfo.procdef._class) then
  355. begin
  356. srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE');
  357. if assigned(srsym) and
  358. (srsym.typ=procsym) then
  359. begin
  360. { if self<>0 and vmt=1 then freeinstance }
  361. addstatement(newstatement,cifnode.create(
  362. caddnode.create(andn,
  363. caddnode.create(unequaln,
  364. load_self_pointer_node,
  365. cnilnode.create),
  366. caddnode.create(equaln,
  367. ctypeconvnode.create(
  368. load_vmt_pointer_node,
  369. voidpointertype),
  370. cpointerconstnode.create(1,voidpointertype))),
  371. ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
  372. nil));
  373. end
  374. else
  375. internalerror(200305108);
  376. end
  377. else
  378. if is_object(current_procinfo.procdef._class) then
  379. begin
  380. { finalize object data }
  381. if current_procinfo.procdef._class.needs_inittable then
  382. addstatement(newstatement,finalize_data_node(load_self_node));
  383. { parameter 3 : vmt_offset }
  384. { parameter 2 : pointer to vmt }
  385. { parameter 1 : self pointer }
  386. para:=ccallparanode.create(
  387. cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
  388. ccallparanode.create(
  389. ctypeconvnode.create_internal(
  390. load_vmt_pointer_node,
  391. voidpointertype),
  392. ccallparanode.create(
  393. ctypeconvnode.create_internal(
  394. load_self_pointer_node,
  395. voidpointertype),
  396. nil)));
  397. addstatement(newstatement,
  398. ccallnode.createintern('fpc_help_destructor',para));
  399. end
  400. else
  401. internalerror(200305105);
  402. end;
  403. end;
  404. end;
  405. function generate_except_block:tnode;
  406. var
  407. pd : tprocdef;
  408. newstatement : tstatementnode;
  409. begin
  410. generate_except_block:=internalstatements(newstatement);
  411. { a constructor needs call destructor (if available) when it
  412. is not inherited }
  413. if assigned(current_procinfo.procdef._class) and
  414. (current_procinfo.procdef.proctypeoption=potype_constructor) then
  415. begin
  416. pd:=current_procinfo.procdef._class.searchdestructor;
  417. if assigned(pd) then
  418. begin
  419. { if vmt<>0 then call destructor }
  420. addstatement(newstatement,cifnode.create(
  421. caddnode.create(unequaln,
  422. load_vmt_pointer_node,
  423. cnilnode.create),
  424. ccallnode.create(nil,tprocsym(pd.procsym),pd.procsym.owner,load_self_node,[]),
  425. nil));
  426. end;
  427. end
  428. else
  429. begin
  430. { no constructor }
  431. { must be the return value finalized before reraising the exception? }
  432. if (not is_void(current_procinfo.procdef.rettype.def)) and
  433. (current_procinfo.procdef.rettype.def.needs_inittable) and
  434. (not is_class(current_procinfo.procdef.rettype.def)) then
  435. addstatement(newstatement,finalize_data_node(load_result_node));
  436. end;
  437. end;
  438. {****************************************************************************
  439. TCGProcInfo
  440. ****************************************************************************}
  441. constructor tcgprocinfo.create(aparent:tprocinfo);
  442. begin
  443. inherited Create(aparent);
  444. nestedprocs:=tlinkedlist.create;
  445. end;
  446. destructor tcgprocinfo.destroy;
  447. begin
  448. nestedprocs.free;
  449. if assigned(code) then
  450. code.free;
  451. inherited destroy;
  452. end;
  453. procedure tcgprocinfo.printproc;
  454. begin
  455. assign(printnodefile,treelogfilename);
  456. {$I-}
  457. append(printnodefile);
  458. if ioresult<>0 then
  459. rewrite(printnodefile);
  460. {$I+}
  461. if ioresult<>0 then
  462. begin
  463. Comment(V_Error,'Error creating '+treelogfilename);
  464. exit;
  465. end;
  466. writeln(printnodefile);
  467. writeln(printnodefile,'*******************************************************************************');
  468. writeln(printnodefile,procdef.fullprocname(false));
  469. writeln(printnodefile,'*******************************************************************************');
  470. printnode(printnodefile,code);
  471. close(printnodefile);
  472. end;
  473. procedure tcgprocinfo.add_entry_exit_code;
  474. var
  475. finalcode,
  476. bodyentrycode,
  477. bodyexitcode,
  478. exceptcode : tnode;
  479. newblock : tblocknode;
  480. codestatement,
  481. newstatement : tstatementnode;
  482. oldfilepos : tfileposinfo;
  483. begin
  484. oldfilepos:=aktfilepos;
  485. { Generate code/locations used at start of proc }
  486. aktfilepos:=entrypos;
  487. entry_asmnode:=casmnode.create_get_position;
  488. loadpara_asmnode:=casmnode.create_get_position;
  489. stackcheck_asmnode:=casmnode.create_get_position;
  490. init_asmnode:=casmnode.create_get_position;
  491. bodyentrycode:=generate_bodyentry_block;
  492. { Generate code/locations used at end of proc }
  493. aktfilepos:=exitpos;
  494. exitlabel_asmnode:=casmnode.create_get_position;
  495. final_asmnode:=casmnode.create_get_position;
  496. bodyexitcode:=generate_bodyexit_block;
  497. { Generate procedure by combining init+body+final,
  498. depending on the implicit finally we need to add
  499. an try...finally...end wrapper }
  500. newblock:=internalstatements(newstatement);
  501. if (cs_implicit_exceptions in aktmoduleswitches) and
  502. (pi_needs_implicit_finally in flags) and
  503. { but it's useless in init/final code of units }
  504. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
  505. begin
  506. { Generate special exception block only needed when
  507. implicit finaly is used }
  508. aktfilepos:=exitpos;
  509. exceptcode:=generate_except_block;
  510. { Generate code that will be in the try...finally }
  511. finalcode:=internalstatements(codestatement);
  512. addstatement(codestatement,bodyexitcode);
  513. addstatement(codestatement,final_asmnode);
  514. { Initialize before try...finally...end frame }
  515. addstatement(newstatement,loadpara_asmnode);
  516. addstatement(newstatement,stackcheck_asmnode);
  517. addstatement(newstatement,entry_asmnode);
  518. addstatement(newstatement,init_asmnode);
  519. addstatement(newstatement,bodyentrycode);
  520. aktfilepos:=entrypos;
  521. addstatement(newstatement,ctryfinallynode.create_implicit(
  522. code,
  523. finalcode,
  524. exceptcode));
  525. addstatement(newstatement,exitlabel_asmnode);
  526. { set flag the implicit finally has been generated }
  527. include(flags,pi_has_implicit_finally);
  528. end
  529. else
  530. begin
  531. addstatement(newstatement,loadpara_asmnode);
  532. addstatement(newstatement,stackcheck_asmnode);
  533. addstatement(newstatement,entry_asmnode);
  534. addstatement(newstatement,init_asmnode);
  535. addstatement(newstatement,bodyentrycode);
  536. addstatement(newstatement,code);
  537. addstatement(newstatement,exitlabel_asmnode);
  538. addstatement(newstatement,bodyexitcode);
  539. addstatement(newstatement,final_asmnode);
  540. end;
  541. do_firstpass(newblock);
  542. code:=newblock;
  543. aktfilepos:=oldfilepos;
  544. end;
  545. procedure clearrefs(p : tnamedindexitem;arg:pointer);
  546. begin
  547. if (tsym(p).typ in [localvarsym,paravarsym,globalvarsym]) then
  548. if tabstractvarsym(p).refs>1 then
  549. tabstractvarsym(p).refs:=1;
  550. end;
  551. procedure tcgprocinfo.generate_code;
  552. var
  553. oldprocinfo : tprocinfo;
  554. oldaktmaxfpuregisters : longint;
  555. oldfilepos : tfileposinfo;
  556. templist : Taasmoutput;
  557. headertai : tai;
  558. begin
  559. { the initialization procedure can be empty, then we
  560. don't need to generate anything. When it was an empty
  561. procedure there would be at least a blocknode }
  562. if not assigned(code) then
  563. exit;
  564. { We need valid code }
  565. if Errorcount<>0 then
  566. exit;
  567. { The RA and Tempgen shall not be available yet }
  568. if assigned(tg) then
  569. internalerror(200309201);
  570. oldprocinfo:=current_procinfo;
  571. oldfilepos:=aktfilepos;
  572. oldaktmaxfpuregisters:=aktmaxfpuregisters;
  573. current_procinfo:=self;
  574. aktfilepos:=entrypos;
  575. { get new labels }
  576. aktbreaklabel:=nil;
  577. aktcontinuelabel:=nil;
  578. templist:=Taasmoutput.create;
  579. { add parast/localst to symtablestack }
  580. add_to_symtablestack;
  581. { when size optimization only count occurrence }
  582. if cs_littlesize in aktglobalswitches then
  583. cg.t_times:=1
  584. else
  585. { reference for repetition is 100 }
  586. cg.t_times:=100;
  587. { clear register count }
  588. symtablestack.foreach_static(@clearrefs,nil);
  589. symtablestack.next.foreach_static(@clearrefs,nil);
  590. { there's always a call to FPC_INITIALIZEUNITS/FPC_DO_EXIT in the main program }
  591. if (procdef.localst.symtablelevel=main_program_level) and
  592. (not current_module.is_unit) then
  593. include(flags,pi_do_call);
  594. { set implicit_finally flag when there are locals/paras to be finalized }
  595. current_procinfo.procdef.parast.foreach_static(@check_finalize_paras,nil);
  596. current_procinfo.procdef.localst.foreach_static(@check_finalize_locals,nil);
  597. { firstpass everything }
  598. flowcontrol:=[];
  599. do_firstpass(code);
  600. if code.registersfpu>0 then
  601. include(current_procinfo.flags,pi_uses_fpu);
  602. { add implicit entry and exit code }
  603. add_entry_exit_code;
  604. { only do secondpass if there are no errors }
  605. if ErrorCount=0 then
  606. begin
  607. { set the start offset to the start of the temp area in the stack }
  608. tg:=ttgobj.create;
  609. { Create register allocator }
  610. cg.init_register_allocators;
  611. set_first_temp_offset;
  612. generate_parameter_info;
  613. { Allocate space in temp/registers for parast and localst }
  614. aktfilepos:=entrypos;
  615. gen_alloc_symtable(aktproccode,procdef.parast);
  616. gen_alloc_symtable(aktproccode,procdef.localst);
  617. { Store temp offset for information about 'real' temps }
  618. tempstart:=tg.lasttemp;
  619. { Generate code to load register parameters in temps and insert local
  620. copies for values parameters. This must be done before the code for the
  621. body is generated because the localloc is updated.
  622. Note: The generated code will be inserted after the code generation of
  623. the body is finished, because only then the position is known }
  624. {$ifdef oldregvars}
  625. assign_regvars(code);
  626. {$endif oldreg}
  627. aktfilepos:=entrypos;
  628. gen_load_para_value(templist);
  629. { caller paraloc info is also necessary in the stackframe_entry
  630. code of the ppc (and possibly other processors) }
  631. if not procdef.has_paraloc_info then
  632. begin
  633. procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
  634. procdef.has_paraloc_info:=true;
  635. end;
  636. { generate code for the node tree }
  637. do_secondpass(code);
  638. aktproccode.concatlist(exprasmlist);
  639. {$ifdef i386}
  640. procdef.fpu_used:=code.registersfpu;
  641. {$endif i386}
  642. { The position of the loadpara_asmnode is now known }
  643. aktproccode.insertlistafter(loadpara_asmnode.currenttai,templist);
  644. { first generate entry and initialize code with the correct
  645. position and switches }
  646. aktfilepos:=entrypos;
  647. aktlocalswitches:=entryswitches;
  648. gen_entry_code(templist);
  649. aktproccode.insertlistafter(entry_asmnode.currenttai,templist);
  650. gen_initialize_code(templist);
  651. aktproccode.insertlistafter(init_asmnode.currenttai,templist);
  652. { now generate finalize and exit code with the correct position
  653. and switches }
  654. aktfilepos:=exitpos;
  655. aktlocalswitches:=exitswitches;
  656. gen_finalize_code(templist);
  657. { the finalcode must be concated if there was no position available,
  658. using insertlistafter will result in an insert at the start
  659. when currentai=nil }
  660. if assigned(final_asmnode.currenttai) then
  661. aktproccode.insertlistafter(final_asmnode.currenttai,templist)
  662. else
  663. aktproccode.concatlist(templist);
  664. { insert exit label at the correct position }
  665. cg.a_label(templist,aktexitlabel);
  666. if assigned(exitlabel_asmnode.currenttai) then
  667. aktproccode.insertlistafter(exitlabel_asmnode.currenttai,templist)
  668. else
  669. aktproccode.concatlist(templist);
  670. { exit code }
  671. gen_exit_code(templist);
  672. aktproccode.concatlist(templist);
  673. {$ifdef OLDREGVARS}
  674. { note: this must be done only after as much code as possible has }
  675. { been generated. The result is that when you ungetregister() a }
  676. { regvar, it will actually free the regvar (and alse free the }
  677. { the regvars at the same time). Doing this too early will }
  678. { confuse the register allocator, as the regvars will still be }
  679. { used. It should be done before loading the result regs (so }
  680. { they don't conflict with the regvars) and before }
  681. { gen_entry_code (that one has to be able to allocate the }
  682. { regvars again) (JM) }
  683. free_regvars(aktproccode);
  684. {$endif OLDREGVARS}
  685. { add code that will load the return value, this is not done
  686. for assembler routines when they didn't reference the result
  687. variable }
  688. gen_load_return_value(templist);
  689. aktproccode.concatlist(templist);
  690. { generate symbol and save end of header position }
  691. aktfilepos:=entrypos;
  692. gen_proc_symbol(templist);
  693. headertai:=tai(templist.last);
  694. { insert symbol }
  695. aktproccode.insertlist(templist);
  696. { Free space in temp/registers for parast and localst, must be
  697. done after gen_entry_code }
  698. aktfilepos:=exitpos;
  699. gen_free_symtable(aktproccode,procdef.localst);
  700. gen_free_symtable(aktproccode,procdef.parast);
  701. { Already reserve all registers for stack checking code and
  702. generate the call to the helper function }
  703. if (cs_check_stack in entryswitches) and
  704. not(po_assembler in procdef.procoptions) and
  705. (current_procinfo.procdef.proctypeoption<>potype_proginit) then
  706. begin
  707. aktfilepos:=entrypos;
  708. gen_stack_check_call(templist);
  709. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  710. end;
  711. { The procedure body is finished, we can now
  712. allocate the registers }
  713. cg.do_register_allocation(aktproccode,headertai);
  714. { Add save and restore of used registers }
  715. aktfilepos:=entrypos;
  716. gen_save_used_regs(templist);
  717. aktproccode.insertlistafter(headertai,templist);
  718. aktfilepos:=exitpos;
  719. gen_restore_used_regs(aktproccode);
  720. { We know the size of the stack, now we can generate the
  721. parameter that is passed to the stack checking code }
  722. if (cs_check_stack in entryswitches) and
  723. not(po_assembler in procdef.procoptions) and
  724. (current_procinfo.procdef.proctypeoption<>potype_proginit) then
  725. begin
  726. aktfilepos:=entrypos;
  727. gen_stack_check_size_para(templist);
  728. aktproccode.insertlistafter(stackcheck_asmnode.currenttai,templist)
  729. end;
  730. { Add entry code (stack allocation) after header }
  731. aktfilepos:=entrypos;
  732. gen_proc_entry_code(templist);
  733. aktproccode.insertlistafter(headertai,templist);
  734. { Add exit code at the end }
  735. aktfilepos:=exitpos;
  736. gen_proc_exit_code(templist);
  737. aktproccode.concatlist(templist);
  738. { check if the implicit finally has been generated. The flag
  739. should already be set in pass1 }
  740. if (cs_implicit_exceptions in aktmoduleswitches) and
  741. not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and
  742. (pi_needs_implicit_finally in flags) and
  743. not(pi_has_implicit_finally in flags) then
  744. internalerror(200405231);
  745. {$ifndef NoOpt}
  746. if not(cs_no_regalloc in aktglobalswitches) then
  747. begin
  748. if (cs_optimize in aktglobalswitches) and
  749. { do not optimize pure assembler procedures }
  750. not(pi_is_assembler in flags) then
  751. optimize(aktproccode);
  752. end;
  753. {$endif NoOpt}
  754. { Add end symbol and debug info }
  755. aktfilepos:=exitpos;
  756. gen_proc_symbol_end(templist);
  757. aktproccode.concatlist(templist);
  758. {$ifdef ARM}
  759. insertpcrelativedata(aktproccode,aktlocaldata);
  760. {$endif ARM}
  761. { save local data (casetable) also in the same file }
  762. if assigned(aktlocaldata) and
  763. (not aktlocaldata.empty) then
  764. begin
  765. { because of the limited constant size of the arm, all data access is done pc relative }
  766. if target_info.cpu=cpu_arm then
  767. aktproccode.concatlist(aktlocaldata)
  768. else
  769. begin
  770. new_section(aktproccode,sec_data,lower(procdef.mangledname),0);
  771. aktproccode.concatlist(aktlocaldata);
  772. end;
  773. end;
  774. { add the procedure to the codesegment }
  775. maybe_new_object_file(codesegment);
  776. new_section(codesegment,sec_code,lower(procdef.mangledname),aktalignment.procalign);
  777. codesegment.concatlist(aktproccode);
  778. { only now we can remove the temps }
  779. tg.resettempgen;
  780. { stop tempgen and ra }
  781. tg.free;
  782. cg.done_register_allocators;
  783. tg:=nil;
  784. end;
  785. { restore symtablestack }
  786. remove_from_symtablestack;
  787. { restore }
  788. templist.free;
  789. aktmaxfpuregisters:=oldaktmaxfpuregisters;
  790. aktfilepos:=oldfilepos;
  791. current_procinfo:=oldprocinfo;
  792. end;
  793. procedure tcgprocinfo.add_to_symtablestack;
  794. var
  795. _class,hp : tobjectdef;
  796. begin
  797. { insert symtables for the class, but only if it is no nested function }
  798. if assigned(procdef._class) and
  799. not(assigned(parent) and
  800. assigned(parent.procdef) and
  801. assigned(parent.procdef._class)) then
  802. begin
  803. { insert them in the reverse order }
  804. hp:=nil;
  805. repeat
  806. _class:=procdef._class;
  807. while _class.childof<>hp do
  808. _class:=_class.childof;
  809. hp:=_class;
  810. _class.symtable.next:=symtablestack;
  811. symtablestack:=_class.symtable;
  812. until hp=procdef._class;
  813. end;
  814. { insert parasymtable in symtablestack when parsing
  815. a function }
  816. if procdef.parast.symtablelevel>=normal_function_level then
  817. begin
  818. procdef.parast.next:=symtablestack;
  819. symtablestack:=procdef.parast;
  820. end;
  821. procdef.localst.next:=symtablestack;
  822. symtablestack:=procdef.localst;
  823. end;
  824. procedure tcgprocinfo.remove_from_symtablestack;
  825. begin
  826. { remove localst/parast }
  827. if procdef.parast.symtablelevel>=normal_function_level then
  828. symtablestack:=symtablestack.next.next
  829. else
  830. symtablestack:=symtablestack.next;
  831. { remove class member symbol tables }
  832. while symtablestack.symtabletype=objectsymtable do
  833. symtablestack:=symtablestack.next;
  834. end;
  835. procedure tcgprocinfo.resetprocdef;
  836. begin
  837. { remove code tree, if not inline procedure }
  838. if assigned(code) then
  839. begin
  840. { the inline procedure has already got a copy of the tree
  841. stored in procdef.inlininginfo }
  842. code.free;
  843. code:=nil;
  844. end;
  845. end;
  846. function checknodeinlining(procdef: tprocdef): boolean;
  847. var
  848. i : integer;
  849. currpara : tparavarsym;
  850. begin
  851. result := false;
  852. if (pi_has_assembler_block in current_procinfo.flags) then
  853. exit;
  854. for i:=0 to procdef.paras.count-1 do
  855. begin
  856. currpara:=tparavarsym(procdef.paras[i]);
  857. { we can't handle formaldefs and special arrays (the latter may need a }
  858. { re-basing of the index, i.e. if you pass an array[1..10] as open array, }
  859. { you have to add 1 to all index operations if you directly inline it }
  860. if ((currpara.varspez in [vs_out,vs_var]) and
  861. (currpara.vartype.def.deftype=formaldef)) or
  862. is_special_array(currpara.vartype.def) then
  863. exit;
  864. end;
  865. result:=true;
  866. end;
  867. procedure tcgprocinfo.parse_body;
  868. var
  869. oldprocinfo : tprocinfo;
  870. oldblock_type : tblock_type;
  871. begin
  872. oldprocinfo:=current_procinfo;
  873. oldblock_type:=block_type;
  874. { reset break and continue labels }
  875. block_type:=bt_body;
  876. current_procinfo:=self;
  877. { calculate the lexical level }
  878. if procdef.parast.symtablelevel>maxnesting then
  879. Message(parser_e_too_much_lexlevel);
  880. { static is also important for local procedures !! }
  881. if (po_staticmethod in procdef.procoptions) then
  882. allow_only_static:=true
  883. else if (procdef.parast.symtablelevel=normal_function_level) then
  884. allow_only_static:=false;
  885. {$ifdef state_tracking}
  886. { aktstate:=Tstate_storage.create;}
  887. {$endif state_tracking}
  888. { create a local symbol table for this routine }
  889. if not assigned(procdef.localst) then
  890. procdef.insert_localst;
  891. { add parast/localst to symtablestack }
  892. add_to_symtablestack;
  893. { constant symbols are inserted in this symboltable }
  894. constsymtable:=symtablestack;
  895. { save entry info }
  896. entrypos:=aktfilepos;
  897. entryswitches:=aktlocalswitches;
  898. { parse the code ... }
  899. code:=block(current_module.islibrary);
  900. { save exit info }
  901. exitswitches:=aktlocalswitches;
  902. exitpos:=last_endtoken_filepos;
  903. { the procedure is now defined }
  904. procdef.forwarddef:=false;
  905. if assigned(code) then
  906. begin
  907. { get a better entry point }
  908. entrypos:=code.fileinfo;
  909. { Finish type checking pass }
  910. do_resulttypepass(code);
  911. end;
  912. { Check for unused labels, forwards, symbols for procedures. Static
  913. symtable is checked in pmodules.
  914. The check must be done after the resulttypepass }
  915. if (Errorcount=0) and
  916. (tstoredsymtable(procdef.localst).symtabletype<>staticsymtable) then
  917. begin
  918. { check if forwards are resolved }
  919. tstoredsymtable(procdef.localst).check_forwards;
  920. { check if all labels are used }
  921. tstoredsymtable(procdef.localst).checklabels;
  922. { remove cross unit overloads }
  923. tstoredsymtable(procdef.localst).unchain_overloaded;
  924. { check for unused symbols, but only if there is no asm block }
  925. if not(pi_has_assembler_block in flags) then
  926. begin
  927. tstoredsymtable(procdef.localst).allsymbolsused;
  928. tstoredsymtable(procdef.parast).allsymbolsused;
  929. end;
  930. end;
  931. if (procdef.proccalloption=pocall_inline) then
  932. begin
  933. { Can we inline this procedure? }
  934. if checknodeinlining(procdef) then
  935. begin
  936. new(procdef.inlininginfo);
  937. include(procdef.procoptions,po_has_inlininginfo);
  938. procdef.inlininginfo^.code:=code.getcopy;
  939. procdef.inlininginfo^.flags:=current_procinfo.flags;
  940. { The blocknode needs to set an exit label }
  941. if procdef.inlininginfo^.code.nodetype=blockn then
  942. include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
  943. end;
  944. end;
  945. { Print the node to tree.log }
  946. if paraprintnodetree=1 then
  947. printproc;
  948. { ... remove symbol tables }
  949. remove_from_symtablestack;
  950. {$ifdef state_tracking}
  951. { aktstate.destroy;}
  952. {$endif state_tracking}
  953. { reset to normal non static function }
  954. if (procdef.parast.symtablelevel=normal_function_level) then
  955. allow_only_static:=false;
  956. current_procinfo:=oldprocinfo;
  957. block_type:=oldblock_type;
  958. end;
  959. {****************************************************************************
  960. PROCEDURE/FUNCTION PARSING
  961. ****************************************************************************}
  962. procedure check_init_paras(p:tnamedindexitem;arg:pointer);
  963. begin
  964. if tsym(p).typ<>paravarsym then
  965. exit;
  966. with tparavarsym(p) do
  967. if (not is_class(vartype.def) and
  968. vartype.def.needs_inittable and
  969. (varspez in [vs_value,vs_out])) then
  970. include(current_procinfo.flags,pi_do_call);
  971. end;
  972. procedure read_proc;
  973. {
  974. Parses the procedure directives, then parses the procedure body, then
  975. generates the code for it
  976. }
  977. procedure do_generate_code(pi:tcgprocinfo);
  978. var
  979. hpi : tcgprocinfo;
  980. begin
  981. { generate code for this procedure }
  982. pi.generate_code;
  983. { process nested procs }
  984. hpi:=tcgprocinfo(pi.nestedprocs.first);
  985. while assigned(hpi) do
  986. begin
  987. do_generate_code(hpi);
  988. hpi:=tcgprocinfo(hpi.next);
  989. end;
  990. pi.resetprocdef;
  991. end;
  992. var
  993. old_current_procinfo : tprocinfo;
  994. oldconstsymtable : tsymtable;
  995. oldfailtokenmode : tmodeswitch;
  996. pdflags : tpdflags;
  997. pd : tprocdef;
  998. isnestedproc : boolean;
  999. s : string;
  1000. begin
  1001. { save old state }
  1002. oldconstsymtable:=constsymtable;
  1003. old_current_procinfo:=current_procinfo;
  1004. { reset current_procinfo.procdef to nil to be sure that nothing is writing
  1005. to an other procdef }
  1006. current_procinfo:=nil;
  1007. { parse procedure declaration }
  1008. if assigned(old_current_procinfo) and
  1009. assigned(old_current_procinfo.procdef) then
  1010. pd:=parse_proc_dec(old_current_procinfo.procdef._class)
  1011. else
  1012. pd:=parse_proc_dec(nil);
  1013. { set the default function options }
  1014. if parse_only then
  1015. begin
  1016. pd.forwarddef:=true;
  1017. { set also the interface flag, for better error message when the
  1018. implementation doesn't much this header }
  1019. pd.interfacedef:=true;
  1020. include(pd.procoptions,po_global);
  1021. pdflags:=[pd_interface];
  1022. end
  1023. else
  1024. begin
  1025. pdflags:=[pd_body];
  1026. if (not current_module.in_interface) then
  1027. include(pdflags,pd_implemen);
  1028. if (not current_module.is_unit) or
  1029. maybe_smartlink_symbol then
  1030. include(pd.procoptions,po_global);
  1031. pd.forwarddef:=false;
  1032. end;
  1033. { parse the directives that may follow }
  1034. parse_proc_directives(pd,pdflags);
  1035. { hint directives, these can be separated by semicolons here,
  1036. that needs to be handled here with a loop (PFV) }
  1037. while try_consume_hintdirective(pd.symoptions) do
  1038. Consume(_SEMICOLON);
  1039. { Set calling convention }
  1040. handle_calling_convention(pd);
  1041. { search for forward declarations }
  1042. if not proc_add_definition(pd) then
  1043. begin
  1044. { A method must be forward defined (in the object declaration) }
  1045. if assigned(pd._class) and
  1046. (not assigned(old_current_procinfo.procdef._class)) then
  1047. begin
  1048. MessagePos1(pd.fileinfo,parser_e_header_dont_match_any_member,pd.fullprocname(false));
  1049. tprocsym(pd.procsym).write_parameter_lists(pd);
  1050. end
  1051. else
  1052. begin
  1053. { Give a better error if there is a forward def in the interface and only
  1054. a single implementation }
  1055. if (not pd.forwarddef) and
  1056. (not pd.interfacedef) and
  1057. (tprocsym(pd.procsym).procdef_count>1) and
  1058. tprocsym(pd.procsym).first_procdef.forwarddef and
  1059. tprocsym(pd.procsym).first_procdef.interfacedef and
  1060. not(tprocsym(pd.procsym).procdef_count>2) then
  1061. begin
  1062. MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
  1063. tprocsym(pd.procsym).write_parameter_lists(pd);
  1064. end;
  1065. end;
  1066. end;
  1067. { Set mangled name }
  1068. proc_set_mangledname(pd);
  1069. { compile procedure when a body is needed }
  1070. if (pd_body in pdflags) then
  1071. begin
  1072. Message1(parser_d_procedure_start,pd.fullprocname(false));
  1073. { create a new procedure }
  1074. current_procinfo:=cprocinfo.create(old_current_procinfo);
  1075. current_module.procinfo:=current_procinfo;
  1076. current_procinfo.procdef:=pd;
  1077. isnestedproc:=(current_procinfo.procdef.parast.symtablelevel>normal_function_level);
  1078. { Insert mangledname }
  1079. pd.aliasnames.insert(pd.mangledname);
  1080. { Handle Export of this procedure }
  1081. if (po_exports in pd.procoptions) and
  1082. (target_info.system in [system_i386_os2,system_i386_emx]) then
  1083. begin
  1084. pd.aliasnames.insert(pd.procsym.realname);
  1085. if cs_link_deffile in aktglobalswitches then
  1086. deffile.AddExport(pd.mangledname);
  1087. end;
  1088. { Insert result variables in the localst }
  1089. insert_funcret_local(pd);
  1090. { check if there are para's which require initing -> set }
  1091. { pi_do_call (if not yet set) }
  1092. if not(pi_do_call in current_procinfo.flags) then
  1093. pd.parast.foreach_static(@check_init_paras,nil);
  1094. { set _FAIL as keyword if constructor }
  1095. if (pd.proctypeoption=potype_constructor) then
  1096. begin
  1097. oldfailtokenmode:=tokeninfo^[_FAIL].keyword;
  1098. tokeninfo^[_FAIL].keyword:=m_all;
  1099. end;
  1100. tcgprocinfo(current_procinfo).parse_body;
  1101. { When it's a nested procedure then defer the code generation,
  1102. when back at normal function level then generate the code
  1103. for all defered nested procedures and the current procedure }
  1104. if isnestedproc then
  1105. tcgprocinfo(current_procinfo.parent).nestedprocs.insert(current_procinfo)
  1106. else
  1107. begin
  1108. { We can't support inlining for procedures that have nested
  1109. procedures because the nested procedures use a fixed offset
  1110. for accessing locals in the parent procedure (PFV) }
  1111. if (current_procinfo.procdef.proccalloption=pocall_inline) and
  1112. (tcgprocinfo(current_procinfo).nestedprocs.count>0) then
  1113. begin
  1114. Message1(parser_w_not_supported_for_inline,'nested procedures');
  1115. Message(parser_w_inlining_disabled);
  1116. current_procinfo.procdef.proccalloption:=pocall_default;
  1117. end;
  1118. do_generate_code(tcgprocinfo(current_procinfo));
  1119. end;
  1120. { reset _FAIL as _SELF normal }
  1121. if (pd.proctypeoption=potype_constructor) then
  1122. tokeninfo^[_FAIL].keyword:=oldfailtokenmode;
  1123. { release procinfo }
  1124. if tprocinfo(current_module.procinfo)<>current_procinfo then
  1125. internalerror(200304274);
  1126. current_module.procinfo:=current_procinfo.parent;
  1127. if not isnestedproc then
  1128. current_procinfo.free;
  1129. consume(_SEMICOLON);
  1130. end
  1131. else
  1132. begin
  1133. { Handle imports }
  1134. if (po_external in pd.procoptions) then
  1135. begin
  1136. { External declared in implementation, and there was already a
  1137. forward (or interface) declaration then we need to generate
  1138. a stub that calls the external routine }
  1139. if (not pd.forwarddef) and
  1140. (pd.hasforward) and
  1141. not(
  1142. assigned(pd.import_dll) and
  1143. (target_info.system in [system_i386_win32,system_i386_wdosx,
  1144. system_i386_emx,system_i386_os2])
  1145. ) then
  1146. begin
  1147. s:=proc_get_importname(pd);
  1148. if s<>'' then
  1149. gen_external_stub(codesegment,pd,s);
  1150. end;
  1151. { Import DLL specified? }
  1152. if assigned(pd.import_dll) then
  1153. begin
  1154. { create importlib if not already done }
  1155. if not(current_module.uses_imports) then
  1156. begin
  1157. current_module.uses_imports:=true;
  1158. importlib.preparelib(current_module.realmodulename^);
  1159. end;
  1160. if assigned(pd.import_name) then
  1161. importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,pd.import_name^)
  1162. else
  1163. importlib.importprocedure(pd,pd.import_dll^,pd.import_nr,'');
  1164. end
  1165. else
  1166. begin
  1167. { add import name to external list for DLL scanning }
  1168. if target_info.DllScanSupported then
  1169. current_module.externals.insert(tExternalsItem.create(proc_get_importname(pd)));
  1170. end;
  1171. end;
  1172. end;
  1173. { Restore old state }
  1174. constsymtable:=oldconstsymtable;
  1175. current_procinfo:=old_current_procinfo;
  1176. end;
  1177. {****************************************************************************
  1178. DECLARATION PARSING
  1179. ****************************************************************************}
  1180. { search in symtablestack for not complete classes }
  1181. procedure check_forward_class(p : tnamedindexitem;arg:pointer);
  1182. begin
  1183. if (tsym(p).typ=typesym) and
  1184. (ttypesym(p).restype.def.deftype=objectdef) and
  1185. (oo_is_forward in tobjectdef(ttypesym(p).restype.def).objectoptions) then
  1186. MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
  1187. end;
  1188. procedure read_declarations(islibrary : boolean);
  1189. begin
  1190. repeat
  1191. if not assigned(current_procinfo) then
  1192. internalerror(200304251);
  1193. case token of
  1194. _LABEL:
  1195. label_dec;
  1196. _CONST:
  1197. const_dec;
  1198. _TYPE:
  1199. type_dec;
  1200. _VAR:
  1201. var_dec;
  1202. _THREADVAR:
  1203. threadvar_dec;
  1204. _CONSTRUCTOR,
  1205. _DESTRUCTOR,
  1206. _FUNCTION,
  1207. _PROCEDURE,
  1208. _OPERATOR,
  1209. _CLASS:
  1210. read_proc;
  1211. _EXPORTS:
  1212. begin
  1213. if not(assigned(current_procinfo.procdef.localst)) or
  1214. (current_procinfo.procdef.localst.symtablelevel>main_program_level) or
  1215. (current_module.is_unit) then
  1216. begin
  1217. Message(parser_e_syntax_error);
  1218. consume_all_until(_SEMICOLON);
  1219. end
  1220. else if islibrary or
  1221. (target_info.system in [system_i386_WIN32,system_i386_wdosx,system_i386_Netware,system_i386_netwlibc]) then
  1222. read_exports
  1223. else
  1224. begin
  1225. Message(parser_w_unsupported_feature);
  1226. consume(_BEGIN);
  1227. end;
  1228. end
  1229. else
  1230. begin
  1231. case idtoken of
  1232. _RESOURCESTRING :
  1233. begin
  1234. { m_class is needed, because the resourcestring
  1235. loading is in the ObjPas unit }
  1236. if (m_class in aktmodeswitches) then
  1237. resourcestring_dec
  1238. else
  1239. break;
  1240. end;
  1241. _PROPERTY:
  1242. begin
  1243. if (m_fpc in aktmodeswitches) then
  1244. property_dec
  1245. else
  1246. break;
  1247. end;
  1248. else
  1249. break;
  1250. end;
  1251. end;
  1252. end;
  1253. until false;
  1254. { check for incomplete class definitions, this is only required
  1255. for fpc modes }
  1256. if (m_fpc in aktmodeswitches) then
  1257. symtablestack.foreach_static(@check_forward_class,nil);
  1258. end;
  1259. procedure read_interface_declarations;
  1260. begin
  1261. repeat
  1262. case token of
  1263. _CONST :
  1264. const_dec;
  1265. _TYPE :
  1266. type_dec;
  1267. _VAR :
  1268. var_dec;
  1269. _THREADVAR :
  1270. threadvar_dec;
  1271. _FUNCTION,
  1272. _PROCEDURE,
  1273. _OPERATOR :
  1274. read_proc;
  1275. else
  1276. begin
  1277. case idtoken of
  1278. _RESOURCESTRING :
  1279. resourcestring_dec;
  1280. _PROPERTY:
  1281. begin
  1282. if (m_fpc in aktmodeswitches) then
  1283. property_dec
  1284. else
  1285. break;
  1286. end;
  1287. else
  1288. break;
  1289. end;
  1290. end;
  1291. end;
  1292. until false;
  1293. { check for incomplete class definitions, this is only required
  1294. for fpc modes }
  1295. if (m_fpc in aktmodeswitches) then
  1296. symtablestack.foreach_static(@check_forward_class,nil);
  1297. end;
  1298. end.
  1299. {
  1300. $Log$
  1301. Revision 1.229 2005-01-04 16:36:31 peter
  1302. * fix aftercosntruction calls, vmt=1 is used to indicate that
  1303. afterconstruction needs to be called
  1304. * only accept resourcestring when objpas is loaded
  1305. Revision 1.228 2005/01/03 22:27:56 peter
  1306. * insert stack_check helper call before doing register allocation
  1307. so the used registers can't be reused when parameters are loaded
  1308. into register variables
  1309. Revision 1.227 2004/12/27 16:35:48 peter
  1310. * set flag if a procedure references a symbol in staticsymtable
  1311. Revision 1.226 2004/12/27 14:41:09 jonas
  1312. - disable inlining for any procedure that contains assembler. Could
  1313. be enabled again if the procedure has neither local variables nor
  1314. parameters.
  1315. Revision 1.225 2004/12/15 21:08:15 peter
  1316. * disable inlining across units when the inline procedure references
  1317. a variable or procedure in the static symtable
  1318. Revision 1.224 2004/12/15 17:01:28 peter
  1319. * fixed crash with -vp
  1320. Revision 1.223 2004/12/15 16:00:16 peter
  1321. * external is again allowed in implementation
  1322. Revision 1.222 2004/12/05 12:28:11 peter
  1323. * procvar handling for tp procvar mode fixed
  1324. * proc to procvar moved from addrnode to typeconvnode
  1325. * inlininginfo is now allocated only for inline routines that
  1326. can be inlined, introduced a new flag po_has_inlining_info
  1327. Revision 1.221 2004/12/02 19:26:15 peter
  1328. * disable pass2inline
  1329. Revision 1.220 2004/11/29 18:50:15 peter
  1330. * os2 fixes for import
  1331. * asmsymtype support for intel reader
  1332. Revision 1.219 2004/11/21 17:17:03 florian
  1333. * changed funcret location back to tlocation
  1334. Revision 1.218 2004/11/19 08:17:02 michael
  1335. * Split po_public into po_public and po_global (Peter)
  1336. Revision 1.217 2004/11/17 22:21:35 peter
  1337. mangledname setting moved to place after the complete proc declaration is read
  1338. import generation moved to place where body is also parsed (still gives problems with win32)
  1339. Revision 1.216 2004/11/16 20:32:41 peter
  1340. * fixes for win32 mangledname
  1341. Revision 1.215 2004/11/15 23:35:31 peter
  1342. * tparaitem removed, use tparavarsym instead
  1343. * parameter order is now calculated from paranr value in tparavarsym
  1344. Revision 1.214 2004/11/08 22:09:59 peter
  1345. * tvarsym splitted
  1346. Revision 1.213 2004/11/02 12:55:17 peter
  1347. * nf_internal flag for internal inserted typeconvs. This will
  1348. supress the generation of warning/hints
  1349. Revision 1.212 2004/10/31 18:54:25 peter
  1350. * $fpctarget expands to <cpu>-<os>
  1351. * allow * in middle of the path to support ../*/units/$fpctarget
  1352. Revision 1.211 2004/10/30 15:21:37 florian
  1353. * fixed generic optimizer
  1354. * enabled generic optimizer for sparc
  1355. Revision 1.210 2004/10/24 20:01:08 peter
  1356. * remove saveregister calling convention
  1357. Revision 1.209 2004/10/15 09:14:17 mazen
  1358. - remove $IFDEF DELPHI and related code
  1359. - remove $IFDEF FPCPROCVAR and related code
  1360. Revision 1.208 2004/10/10 20:22:53 peter
  1361. * symtable allocation rewritten
  1362. * loading of parameters to local temps/regs cleanup
  1363. * regvar support for parameters
  1364. * regvar support for staticsymtable (main body)
  1365. Revision 1.207 2004/09/26 17:45:30 peter
  1366. * simple regvar support, not yet finished
  1367. Revision 1.206 2004/09/21 17:25:12 peter
  1368. * paraloc branch merged
  1369. Revision 1.205 2004/09/13 20:34:28 peter
  1370. * keep localst in memory, it is also needed for finalizing
  1371. typedconst
  1372. Revision 1.204 2004/09/04 21:18:47 armin
  1373. * target netwlibc added (libc is preferred for newer netware versions)
  1374. Revision 1.203.4.1 2004/09/17 17:19:26 peter
  1375. * fixed 64 bit unaryminus for sparc
  1376. * fixed 64 bit inlining
  1377. * signness of not operation
  1378. Revision 1.203 2004/08/14 14:50:42 florian
  1379. * fixed several sparc alignment issues
  1380. + Jonas' inline node patch; non functional yet
  1381. Revision 1.202 2004/07/16 21:11:31 jonas
  1382. - disable node-based inlining of routines with special array parameters
  1383. for now (de indexes of open arrays have to be changed, because on the
  1384. caller-side these routines are not necessarily 0-based)
  1385. Revision 1.201 2004/07/15 19:55:40 jonas
  1386. + (incomplete) node_complexity function to assess the complexity of a
  1387. tree
  1388. + support for inlining value and const parameters at the node level
  1389. (all procedures without local variables and without formal parameters
  1390. can now be inlined at the node level)
  1391. Revision 1.200 2004/07/12 09:14:04 jonas
  1392. * inline procedures at the node tree level, but only under some very
  1393. limited circumstances for now (only procedures, and only if they have
  1394. no or only vs_out/vs_var parameters).
  1395. * fixed ppudump for inline procedures
  1396. * fixed ppudump for ppc
  1397. Revision 1.199 2004/07/10 20:24:34 peter
  1398. * put every proc in a new object file
  1399. Revision 1.198 2004/07/09 22:17:32 peter
  1400. * revert has_localst patch
  1401. * replace aktstaticsymtable/aktglobalsymtable with current_module
  1402. Revision 1.197 2004/07/06 19:52:04 peter
  1403. * fix storing of localst in ppu
  1404. Revision 1.196 2004/06/20 08:55:30 florian
  1405. * logs truncated
  1406. Revision 1.195 2004/06/16 20:07:09 florian
  1407. * dwarf branch merged
  1408. Revision 1.194 2004/05/28 21:14:13 peter
  1409. * first load para's to temps before calling entry code (profile
  1410. Revision 1.193 2004/05/24 17:31:12 peter
  1411. * also check local typed const
  1412. Revision 1.192 2004/05/23 18:28:41 peter
  1413. * methodpointer is loaded into a temp when it was a calln
  1414. Revision 1.191 2004/05/23 15:06:21 peter
  1415. * implicit_finally flag must be set in pass1
  1416. * add check whether the implicit frame is generated when expected
  1417. }