psub.pas 79 KB

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