pmodules.pas 89 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453
  1. {
  2. Copyright (c) 1998-2008 by Florian Klaempfl
  3. Handles the parsing and loading of the modules (ppufiles)
  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 pmodules;
  18. {$i fpcdefs.inc}
  19. interface
  20. function proc_unit:boolean;
  21. procedure proc_package;
  22. procedure proc_program(islibrary : boolean);
  23. implementation
  24. uses
  25. SysUtils,
  26. globtype,version,systems,tokens,
  27. cutils,cfileutl,cclasses,comphook,
  28. globals,verbose,fmodule,finput,fppu,globstat,
  29. symconst,symbase,symtype,symdef,symsym,symtable,symcreat,
  30. wpoinfo,
  31. aasmtai,aasmdata,aasmcpu,aasmbase,
  32. cgbase,cgobj,ngenutil,
  33. nbas,nutils,ncgutil,
  34. link,assemble,import,export,gendef,ppu,comprsrc,dbgbase,
  35. cresstr,procinfo,
  36. pexports,
  37. objcgutl,
  38. wpobase,
  39. scanner,pbase,pexpr,psystem,psub,pdecsub,ncgvmt,ncgrtti,
  40. cpuinfo;
  41. procedure create_objectfile;
  42. var
  43. DLLScanner : TDLLScanner;
  44. s : string;
  45. KeepShared : TCmdStrList;
  46. begin
  47. { try to create import entries from system dlls }
  48. if (tf_has_dllscanner in target_info.flags) and
  49. (not current_module.linkOtherSharedLibs.Empty) then
  50. begin
  51. { Init DLLScanner }
  52. if assigned(CDLLScanner[target_info.system]) then
  53. DLLScanner:=CDLLScanner[target_info.system].Create
  54. else
  55. internalerror(200104121);
  56. KeepShared:=TCmdStrList.Create;
  57. { Walk all shared libs }
  58. While not current_module.linkOtherSharedLibs.Empty do
  59. begin
  60. S:=current_module.linkOtherSharedLibs.Getusemask(link_always);
  61. if not DLLScanner.scan(s) then
  62. KeepShared.Concat(s);
  63. end;
  64. DLLscanner.Free;
  65. { Recreate import section }
  66. if (target_info.system in [system_i386_win32,system_i386_wdosx]) then
  67. begin
  68. if assigned(current_asmdata.asmlists[al_imports]) then
  69. current_asmdata.asmlists[al_imports].clear
  70. else
  71. current_asmdata.asmlists[al_imports]:=TAsmList.Create;
  72. importlib.generatelib;
  73. end;
  74. { Readd the not processed files }
  75. while not KeepShared.Empty do
  76. begin
  77. s:=KeepShared.GetFirst;
  78. current_module.linkOtherSharedLibs.add(s,link_always);
  79. end;
  80. KeepShared.Free;
  81. end;
  82. { allow a target-specific pass over all assembler code (used by LLVM
  83. to insert type definitions }
  84. cnodeutils.InsertObjectInfo;
  85. { Start and end module debuginfo, at least required for stabs
  86. to insert n_sourcefile lines }
  87. if (cs_debuginfo in current_settings.moduleswitches) or
  88. (cs_use_lineinfo in current_settings.globalswitches) then
  89. current_debuginfo.insertmoduleinfo;
  90. { create the .s file and assemble it }
  91. if not(create_smartlink_library) or not(tf_no_objectfiles_when_smartlinking in target_info.flags) then
  92. GenerateAsm(false);
  93. { Also create a smartlinked version ? }
  94. if create_smartlink_library then
  95. begin
  96. GenerateAsm(true);
  97. if (af_needar in target_asm.flags) then
  98. Linker.MakeStaticLibrary;
  99. end;
  100. { resource files }
  101. CompileResourceFiles;
  102. end;
  103. procedure insertobjectfile;
  104. { Insert the used object file for this unit in the used list for this unit }
  105. begin
  106. current_module.linkunitofiles.add(current_module.objfilename,link_static);
  107. current_module.flags:=current_module.flags or uf_static_linked;
  108. if create_smartlink_library then
  109. begin
  110. current_module.linkunitstaticlibs.add(current_module.staticlibfilename ,link_smart);
  111. current_module.flags:=current_module.flags or uf_smart_linked;
  112. end;
  113. end;
  114. procedure create_dwarf_frame;
  115. begin
  116. { Dwarf conflicts with smartlinking in separate .a files }
  117. if create_smartlink_library then
  118. exit;
  119. { Call frame information }
  120. { MWE: we write our own info, so dwarf asm support is not really needed }
  121. { if (af_supports_dwarf in target_asm.flags) and }
  122. { CFI is currently broken for Darwin }
  123. if not(target_info.system in systems_darwin) and
  124. (
  125. (tf_needs_dwarf_cfi in target_info.flags) or
  126. (target_dbg.id in [dbg_dwarf2, dbg_dwarf3])
  127. ) then
  128. begin
  129. current_asmdata.asmlists[al_dwarf_frame].Free;
  130. current_asmdata.asmlists[al_dwarf_frame] := TAsmList.create;
  131. current_asmdata.asmcfi.generate_code(current_asmdata.asmlists[al_dwarf_frame]);
  132. end;
  133. end;
  134. Function CheckResourcesUsed : boolean;
  135. var
  136. hp : tused_unit;
  137. found : Boolean;
  138. begin
  139. CheckResourcesUsed:=tf_has_winlike_resources in target_info.flags;
  140. if not CheckResourcesUsed then exit;
  141. hp:=tused_unit(usedunits.first);
  142. found:=((current_module.flags and uf_has_resourcefiles)=uf_has_resourcefiles);
  143. If not found then
  144. While Assigned(hp) and not found do
  145. begin
  146. Found:=((hp.u.flags and uf_has_resourcefiles)=uf_has_resourcefiles);
  147. hp:=tused_unit(hp.next);
  148. end;
  149. CheckResourcesUsed:=found;
  150. end;
  151. procedure AddUnit(const s:string);
  152. var
  153. hp : tppumodule;
  154. unitsym : tunitsym;
  155. begin
  156. { load unit }
  157. hp:=registerunit(current_module,s,'');
  158. hp.loadppu;
  159. hp.adddependency(current_module);
  160. { add to symtable stack }
  161. symtablestack.push(hp.globalsymtable);
  162. if (m_mac in current_settings.modeswitches) and
  163. assigned(hp.globalmacrosymtable) then
  164. macrosymtablestack.push(hp.globalmacrosymtable);
  165. { insert unitsym }
  166. unitsym:=cunitsym.create(s,hp);
  167. inc(unitsym.refs);
  168. tabstractunitsymtable(current_module.localsymtable).insertunit(unitsym);
  169. { add to used units }
  170. current_module.addusedunit(hp,false,unitsym);
  171. end;
  172. procedure maybeloadvariantsunit;
  173. var
  174. hp : tmodule;
  175. begin
  176. { Do we need the variants unit? Skip this
  177. for VarUtils unit for bootstrapping }
  178. if (current_module.flags and uf_uses_variants=0) or
  179. (current_module.modulename^='VARUTILS') then
  180. exit;
  181. { Variants unit already loaded? }
  182. hp:=tmodule(loaded_units.first);
  183. while assigned(hp) do
  184. begin
  185. if hp.modulename^='VARIANTS' then
  186. exit;
  187. hp:=tmodule(hp.next);
  188. end;
  189. { Variants unit is not loaded yet, load it now }
  190. Message(parser_w_implicit_uses_of_variants_unit);
  191. AddUnit('variants');
  192. end;
  193. function MaybeRemoveResUnit : boolean;
  194. var
  195. resources_used : boolean;
  196. hp : tmodule;
  197. uu : tused_unit;
  198. unitname : shortstring;
  199. begin
  200. { We simply remove the unit from:
  201. - usedunit list, so that things like init/finalization table won't
  202. contain references to this unit
  203. - loaded_units list, so that the unit object file doesn't get linked
  204. with the executable. }
  205. { Note: on windows we always need resources! }
  206. resources_used:=(target_info.system in systems_all_windows)
  207. or CheckResourcesUsed;
  208. if (not resources_used) and (tf_has_winlike_resources in target_info.flags) then
  209. begin
  210. { resources aren't used, so we don't need this unit }
  211. if target_res.id=res_ext then
  212. unitname:='FPEXTRES'
  213. else
  214. unitname:='FPINTRES';
  215. Message1(unit_u_unload_resunit,unitname);
  216. { find the module }
  217. hp:=tmodule(loaded_units.first);
  218. while assigned(hp) do
  219. begin
  220. if hp.is_unit and (hp.modulename^=unitname) then break;
  221. hp:=tmodule(hp.next);
  222. end;
  223. if not assigned(hp) then
  224. internalerror(200801071);
  225. { find its tused_unit in the global list }
  226. uu:=tused_unit(usedunits.first);
  227. while assigned(uu) do
  228. begin
  229. if uu.u=hp then break;
  230. uu:=tused_unit(uu.next);
  231. end;
  232. if not assigned(uu) then
  233. internalerror(200801072);
  234. { remove the tused_unit }
  235. usedunits.Remove(uu);
  236. uu.Free;
  237. { remove the module }
  238. loaded_units.Remove(hp);
  239. unloaded_units.Concat(hp);
  240. end;
  241. MaybeRemoveResUnit:=resources_used;
  242. end;
  243. procedure loaddefaultunits;
  244. begin
  245. { we are going to rebuild the symtablestack, clear it first }
  246. symtablestack.clear;
  247. macrosymtablestack.clear;
  248. { macro symtable }
  249. macrosymtablestack.push(initialmacrosymtable);
  250. { are we compiling the system unit? }
  251. if (cs_compilesystem in current_settings.moduleswitches) then
  252. begin
  253. systemunit:=tglobalsymtable(current_module.localsymtable);
  254. { create system defines }
  255. create_intern_types;
  256. create_intern_symbols;
  257. { Set the owner of errorsym and errortype to symtable to
  258. prevent crashes when accessing .owner }
  259. generrorsym.owner:=systemunit;
  260. generrordef.owner:=systemunit;
  261. exit;
  262. end;
  263. { insert the system unit, it is allways the first. Load also the
  264. internal types from the system unit }
  265. AddUnit('system');
  266. systemunit:=tglobalsymtable(symtablestack.top);
  267. load_intern_types;
  268. { Set the owner of errorsym and errortype to symtable to
  269. prevent crashes when accessing .owner }
  270. generrorsym.owner:=systemunit;
  271. generrordef.owner:=systemunit;
  272. { Units only required for main module }
  273. if not(current_module.is_unit) then
  274. begin
  275. { Heaptrc unit, load heaptrace before any other units especially objpas }
  276. if (cs_use_heaptrc in current_settings.globalswitches) then
  277. AddUnit('heaptrc');
  278. { Lineinfo unit }
  279. if (cs_use_lineinfo in current_settings.globalswitches) then begin
  280. case target_dbg.id of
  281. dbg_stabs:
  282. AddUnit('lineinfo');
  283. dbg_stabx:
  284. AddUnit('lnfogdb');
  285. else
  286. AddUnit('lnfodwrf');
  287. end;
  288. end;
  289. { Valgrind requires c memory manager }
  290. if (cs_gdb_valgrind in current_settings.globalswitches) then
  291. AddUnit('cmem');
  292. {$ifdef cpufpemu}
  293. { Floating point emulation unit?
  294. softfpu must be in the system unit anyways (FK)
  295. if (cs_fp_emulation in current_settings.moduleswitches) and not(target_info.system in system_wince) then
  296. AddUnit('softfpu');
  297. }
  298. {$endif cpufpemu}
  299. { Which kind of resource support?
  300. Note: if resources aren't used this unit will be removed later,
  301. otherwise we need it here since it must be loaded quite early }
  302. if (tf_has_winlike_resources in target_info.flags) then
  303. if target_res.id=res_ext then
  304. AddUnit('fpextres')
  305. else
  306. AddUnit('fpintres');
  307. end;
  308. { Objpas unit? }
  309. if m_objpas in current_settings.modeswitches then
  310. AddUnit('objpas');
  311. { Macpas unit? }
  312. if m_mac in current_settings.modeswitches then
  313. AddUnit('macpas');
  314. if m_iso in current_settings.modeswitches then
  315. AddUnit('iso7185');
  316. { blocks support? }
  317. if m_blocks in current_settings.modeswitches then
  318. AddUnit('blockrtl');
  319. { default char=widechar? }
  320. if m_default_unicodestring in current_settings.modeswitches then
  321. AddUnit('uuchar');
  322. { Objective-C support unit? }
  323. if (m_objectivec1 in current_settings.modeswitches) then
  324. begin
  325. { interface to Objective-C run time }
  326. AddUnit('objc');
  327. loadobjctypes;
  328. { NSObject }
  329. if not(current_module.is_unit) or
  330. (current_module.modulename^<>'OBJCBASE') then
  331. AddUnit('objcbase');
  332. end;
  333. { Profile unit? Needed for go32v2 only }
  334. if (cs_profile in current_settings.moduleswitches) and
  335. (target_info.system in [system_i386_go32v2,system_i386_watcom]) then
  336. AddUnit('profile');
  337. if (cs_load_fpcylix_unit in current_settings.globalswitches) then
  338. begin
  339. AddUnit('fpcylix');
  340. AddUnit('dynlibs');
  341. end;
  342. { CPU targets with microcontroller support can add a controller specific unit }
  343. if ControllerSupport and (target_info.system in systems_embedded) and
  344. (current_settings.controllertype<>ct_none) and
  345. (embedded_controllers[current_settings.controllertype].controllerunitstr<>'') then
  346. AddUnit(embedded_controllers[current_settings.controllertype].controllerunitstr);
  347. end;
  348. procedure loadautounits;
  349. var
  350. hs,s : string;
  351. begin
  352. hs:=autoloadunits;
  353. repeat
  354. s:=GetToken(hs,',');
  355. if s='' then
  356. break;
  357. AddUnit(s);
  358. until false;
  359. end;
  360. procedure loadunits(preservest:tsymtable);
  361. var
  362. s,sorg : ansistring;
  363. fn : string;
  364. pu : tused_unit;
  365. hp2 : tmodule;
  366. unitsym : tunitsym;
  367. filepos : tfileposinfo;
  368. begin
  369. consume(_USES);
  370. repeat
  371. s:=pattern;
  372. sorg:=orgpattern;
  373. filepos:=current_tokenpos;
  374. consume(_ID);
  375. while token=_POINT do
  376. begin
  377. consume(_POINT);
  378. s:=s+'.'+pattern;
  379. sorg:=sorg+'.'+orgpattern;
  380. consume(_ID);
  381. end;
  382. { support "<unit> in '<file>'" construct, but not for tp7 }
  383. fn:='';
  384. if not(m_tp7 in current_settings.modeswitches) and
  385. try_to_consume(_OP_IN) then
  386. fn:=FixFileName(get_stringconst);
  387. { Give a warning if lineinfo is loaded }
  388. if s='LINEINFO' then
  389. begin
  390. Message(parser_w_no_lineinfo_use_switch);
  391. if (target_dbg.id in [dbg_dwarf2, dbg_dwarf3]) then
  392. s := 'LNFODWRF';
  393. sorg := s;
  394. end;
  395. { Give a warning if objpas is loaded }
  396. if s='OBJPAS' then
  397. Message(parser_w_no_objpas_use_mode);
  398. { Using the unit itself is not possible }
  399. if (s<>current_module.modulename^) then
  400. begin
  401. { check if the unit is already used }
  402. hp2:=nil;
  403. pu:=tused_unit(current_module.used_units.first);
  404. while assigned(pu) do
  405. begin
  406. if (pu.u.modulename^=s) then
  407. begin
  408. hp2:=pu.u;
  409. break;
  410. end;
  411. pu:=tused_unit(pu.next);
  412. end;
  413. if not assigned(hp2) then
  414. hp2:=registerunit(current_module,sorg,fn)
  415. else
  416. Message1(sym_e_duplicate_id,s);
  417. { Create unitsym, we need to use the name as specified, we
  418. can not use the modulename because that can be different
  419. when -Un is used }
  420. current_tokenpos:=filepos;
  421. unitsym:=cunitsym.create(sorg,nil);
  422. tabstractunitsymtable(current_module.localsymtable).insertunit(unitsym);
  423. { the current module uses the unit hp2 }
  424. current_module.addusedunit(hp2,true,unitsym);
  425. end
  426. else
  427. Message1(sym_e_duplicate_id,s);
  428. if token=_COMMA then
  429. begin
  430. pattern:='';
  431. consume(_COMMA);
  432. end
  433. else
  434. break;
  435. until false;
  436. { Load the units }
  437. pu:=tused_unit(current_module.used_units.first);
  438. while assigned(pu) do
  439. begin
  440. { Only load the units that are in the current
  441. (interface/implementation) uses clause }
  442. if pu.in_uses and
  443. (pu.in_interface=current_module.in_interface) then
  444. begin
  445. tppumodule(pu.u).loadppu;
  446. { is our module compiled? then we can stop }
  447. if current_module.state=ms_compiled then
  448. exit;
  449. { add this unit to the dependencies }
  450. pu.u.adddependency(current_module);
  451. { save crc values }
  452. pu.checksum:=pu.u.crc;
  453. pu.interface_checksum:=pu.u.interface_crc;
  454. pu.indirect_checksum:=pu.u.indirect_crc;
  455. { connect unitsym to the module }
  456. pu.unitsym.module:=pu.u;
  457. { add to symtable stack }
  458. if assigned(preservest) then
  459. symtablestack.pushafter(pu.u.globalsymtable,preservest)
  460. else
  461. symtablestack.push(pu.u.globalsymtable);
  462. if (m_mac in current_settings.modeswitches) and
  463. assigned(pu.u.globalmacrosymtable) then
  464. macrosymtablestack.push(pu.u.globalmacrosymtable);
  465. { check hints }
  466. pu.check_hints;
  467. end;
  468. pu:=tused_unit(pu.next);
  469. end;
  470. end;
  471. procedure reset_all_defs;
  472. begin
  473. if assigned(current_module.wpoinfo) then
  474. current_module.wpoinfo.resetdefs;
  475. end;
  476. procedure free_localsymtables(st:TSymtable);
  477. var
  478. i : longint;
  479. def : tstoreddef;
  480. pd : tprocdef;
  481. begin
  482. for i:=0 to st.DefList.Count-1 do
  483. begin
  484. def:=tstoreddef(st.DefList[i]);
  485. if def.typ=procdef then
  486. begin
  487. pd:=tprocdef(def);
  488. if assigned(pd.localst) and
  489. (pd.localst.symtabletype<>staticsymtable) and
  490. not(po_inline in pd.procoptions) then
  491. begin
  492. free_localsymtables(pd.localst);
  493. pd.localst.free;
  494. pd.localst:=nil;
  495. end;
  496. pd.freeimplprocdefinfo;
  497. end;
  498. end;
  499. end;
  500. procedure free_unregistered_localsymtable_elements;
  501. var
  502. i: longint;
  503. def: tdef;
  504. sym: tsym;
  505. begin
  506. { from high to low so we hopefully have moves of less data }
  507. for i:=current_module.localsymtable.symlist.count-1 downto 0 do
  508. begin
  509. sym:=tsym(current_module.localsymtable.symlist[i]);
  510. { this also frees sym, as the symbols are owned by the symtable }
  511. if not sym.is_registered then
  512. current_module.localsymtable.Delete(sym);
  513. end;
  514. for i:=current_module.localsymtable.deflist.count-1 downto 0 do
  515. begin
  516. def:=tdef(current_module.localsymtable.deflist[i]);
  517. { this also frees def, as the defs are owned by the symtable }
  518. if not def.is_registered and
  519. not(df_not_registered_no_free in def.defoptions) then
  520. current_module.localsymtable.deletedef(def);
  521. end;
  522. end;
  523. procedure setupglobalswitches;
  524. begin
  525. if (cs_create_pic in current_settings.moduleswitches) then
  526. begin
  527. def_system_macro('FPC_PIC');
  528. def_system_macro('PIC');
  529. end;
  530. end;
  531. function create_main_proc(const name:string;potype:tproctypeoption;st:TSymtable):tcgprocinfo;
  532. var
  533. ps : tprocsym;
  534. pd : tprocdef;
  535. begin
  536. { there should be no current_procinfo available }
  537. if assigned(current_procinfo) then
  538. internalerror(200304275);
  539. {Generate a procsym for main}
  540. ps:=cprocsym.create('$'+name);
  541. { main are allways used }
  542. inc(ps.refs);
  543. st.insert(ps);
  544. pd:=tprocdef(cnodeutils.create_main_procdef(target_info.cprefix+name,potype,ps));
  545. { We don't need is a local symtable. Change it into the static
  546. symtable }
  547. if potype<>potype_mainstub then
  548. begin
  549. pd.localst.free;
  550. pd.localst:=st;
  551. end
  552. else
  553. pd.proccalloption:=pocall_cdecl;
  554. handle_calling_convention(pd);
  555. { set procinfo and current_procinfo.procdef }
  556. result:=tcgprocinfo(cprocinfo.create(nil));
  557. result.procdef:=pd;
  558. { main proc does always a call e.g. to init system unit }
  559. include(result.flags,pi_do_call);
  560. end;
  561. procedure release_main_proc(pi:tcgprocinfo);
  562. begin
  563. { remove localst as it was replaced by staticsymtable }
  564. pi.procdef.localst:=nil;
  565. { remove procinfo }
  566. current_module.procinfo:=nil;
  567. pi.free;
  568. pi:=nil;
  569. end;
  570. { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
  571. procedure maybe_load_got;
  572. {$if defined(i386) or defined (sparc)}
  573. var
  574. gotvarsym : tstaticvarsym;
  575. {$endif i386 or sparc}
  576. begin
  577. {$if defined(i386) or defined(sparc)}
  578. if (cs_create_pic in current_settings.moduleswitches) and
  579. (tf_pic_uses_got in target_info.flags) then
  580. begin
  581. { insert symbol for got access in assembler code}
  582. gotvarsym:=cstaticvarsym.create('_GLOBAL_OFFSET_TABLE_',
  583. vs_value,voidpointertype,[vo_is_external]);
  584. gotvarsym.set_mangledname('_GLOBAL_OFFSET_TABLE_');
  585. current_module.localsymtable.insert(gotvarsym);
  586. { avoid unnecessary warnings }
  587. gotvarsym.varstate:=vs_read;
  588. gotvarsym.refs:=1;
  589. end;
  590. {$endif i386 or sparc}
  591. end;
  592. function gen_implicit_initfinal(flag:word;st:TSymtable):tcgprocinfo;
  593. begin
  594. { create procdef }
  595. case flag of
  596. uf_init :
  597. begin
  598. result:=create_main_proc(make_mangledname('',current_module.localsymtable,'init_implicit'),potype_unitinit,st);
  599. result.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
  600. end;
  601. uf_finalize :
  602. begin
  603. result:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize_implicit'),potype_unitfinalize,st);
  604. result.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
  605. if (not current_module.is_unit) then
  606. result.procdef.aliasnames.insert('PASCALFINALIZE');
  607. end;
  608. else
  609. internalerror(200304253);
  610. end;
  611. result.code:=cnothingnode.create;
  612. end;
  613. procedure copy_macro(p:TObject; arg:pointer);
  614. begin
  615. current_module.globalmacrosymtable.insert(tmacro(p).getcopy);
  616. end;
  617. function try_consume_hintdirective(var moduleopt:tmoduleoptions; var deprecatedmsg:pshortstring):boolean;
  618. var
  619. deprecated_seen,
  620. last_is_deprecated:boolean;
  621. begin
  622. try_consume_hintdirective:=false;
  623. deprecated_seen:=false;
  624. repeat
  625. last_is_deprecated:=false;
  626. case idtoken of
  627. _LIBRARY :
  628. begin
  629. include(moduleopt,mo_hint_library);
  630. try_consume_hintdirective:=true;
  631. end;
  632. _DEPRECATED :
  633. begin
  634. { allow deprecated only once }
  635. if deprecated_seen then
  636. break;
  637. include(moduleopt,mo_hint_deprecated);
  638. try_consume_hintdirective:=true;
  639. last_is_deprecated:=true;
  640. deprecated_seen:=true;
  641. end;
  642. _EXPERIMENTAL :
  643. begin
  644. include(moduleopt,mo_hint_experimental);
  645. try_consume_hintdirective:=true;
  646. end;
  647. _PLATFORM :
  648. begin
  649. include(moduleopt,mo_hint_platform);
  650. try_consume_hintdirective:=true;
  651. end;
  652. _UNIMPLEMENTED :
  653. begin
  654. include(moduleopt,mo_hint_unimplemented);
  655. try_consume_hintdirective:=true;
  656. end;
  657. else
  658. break;
  659. end;
  660. consume(Token);
  661. { handle deprecated message }
  662. if ((token=_CSTRING) or (token=_CCHAR)) and last_is_deprecated then
  663. begin
  664. if deprecatedmsg<>nil then
  665. internalerror(201001221);
  666. if token=_CSTRING then
  667. deprecatedmsg:=stringdup(cstringpattern)
  668. else
  669. deprecatedmsg:=stringdup(pattern);
  670. consume(token);
  671. include(moduleopt,mo_has_deprecated_msg);
  672. end;
  673. until false;
  674. end;
  675. {$ifdef jvm}
  676. procedure addmoduleclass;
  677. var
  678. def: tobjectdef;
  679. typesym: ttypesym;
  680. begin
  681. { java_jlobject may not have been parsed yet (system unit); in any
  682. case, we only use this to refer to the class type, so inheritance
  683. does not matter }
  684. def:=cobjectdef.create(odt_javaclass,'__FPC_JVM_Module_Class_Alias$',nil,true);
  685. include(def.objectoptions,oo_is_external);
  686. include(def.objectoptions,oo_is_sealed);
  687. def.objextname:=stringdup(current_module.realmodulename^);
  688. typesym:=ctypesym.create('__FPC_JVM_Module_Class_Alias$',def,true);
  689. symtablestack.top.insert(typesym);
  690. end;
  691. {$endif jvm}
  692. type
  693. tfinishstate=record
  694. init_procinfo:tcgprocinfo;
  695. end;
  696. pfinishstate=^tfinishstate;
  697. procedure finish_unit(module:tmodule;immediate:boolean);forward;
  698. function proc_unit:boolean;
  699. var
  700. main_file: tinputfile;
  701. s1,s2 : ^string; {Saves stack space}
  702. init_procinfo : tcgprocinfo;
  703. unitname : ansistring;
  704. unitname8 : string[8];
  705. i,j : longint;
  706. finishstate:pfinishstate;
  707. globalstate:pglobalstate;
  708. consume_semicolon_after_uses:boolean;
  709. begin
  710. result:=true;
  711. init_procinfo:=nil;
  712. if m_mac in current_settings.modeswitches then
  713. current_module.mode_switch_allowed:= false;
  714. consume(_UNIT);
  715. if compile_level=1 then
  716. Status.IsExe:=false;
  717. unitname:=orgpattern;
  718. consume(_ID);
  719. while token=_POINT do
  720. begin
  721. consume(_POINT);
  722. unitname:=unitname+'.'+orgpattern;
  723. consume(_ID);
  724. end;
  725. { create filenames and unit name }
  726. main_file := current_scanner.inputfile;
  727. while assigned(main_file.next) do
  728. main_file := main_file.next;
  729. new(s1);
  730. s1^:=current_module.modulename^;
  731. current_module.SetFileName(main_file.path+main_file.name,true);
  732. current_module.SetModuleName(unitname);
  733. { check for system unit }
  734. new(s2);
  735. s2^:=upper(ChangeFileExt(ExtractFileName(main_file.name),''));
  736. unitname8:=copy(current_module.modulename^,1,8);
  737. if (cs_check_unit_name in current_settings.globalswitches) and
  738. (
  739. not(
  740. (current_module.modulename^=s2^) or
  741. (
  742. (length(current_module.modulename^)>8) and
  743. (unitname8=s2^)
  744. )
  745. )
  746. or
  747. (
  748. (length(s1^)>8) and
  749. (s1^<>current_module.modulename^)
  750. )
  751. ) then
  752. Message1(unit_e_illegal_unit_name,current_module.realmodulename^);
  753. if (current_module.modulename^='SYSTEM') then
  754. include(current_settings.moduleswitches,cs_compilesystem);
  755. dispose(s2);
  756. dispose(s1);
  757. if (target_info.system in systems_unit_program_exports) then
  758. exportlib.preparelib(current_module.realmodulename^);
  759. { parse hint directives }
  760. try_consume_hintdirective(current_module.moduleoptions, current_module.deprecatedmsg);
  761. consume(_SEMICOLON);
  762. { handle the global switches, do this before interface, because after interface has been
  763. read, all following directives are parsed as well }
  764. setupglobalswitches;
  765. consume(_INTERFACE);
  766. { global switches are read, so further changes aren't allowed }
  767. current_module.in_global:=false;
  768. message1(unit_u_loading_interface_units,current_module.modulename^);
  769. { update status }
  770. status.currentmodule:=current_module.realmodulename^;
  771. { maybe turn off m_objpas if we are compiling objpas }
  772. if (current_module.modulename^='OBJPAS') then
  773. exclude(current_settings.modeswitches,m_objpas);
  774. { maybe turn off m_mac if we are compiling macpas }
  775. if (current_module.modulename^='MACPAS') then
  776. exclude(current_settings.modeswitches,m_mac);
  777. parse_only:=true;
  778. { generate now the global symboltable,
  779. define first as local to overcome dependency conflicts }
  780. current_module.localsymtable:=tglobalsymtable.create(current_module.modulename^,current_module.moduleid);
  781. { insert unitsym of this unit to prevent other units having
  782. the same name }
  783. tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
  784. { load default units, like the system unit }
  785. loaddefaultunits;
  786. { insert qualifier for the system unit (allows system.writeln) }
  787. if not(cs_compilesystem in current_settings.moduleswitches) and
  788. (token=_USES) then
  789. begin
  790. loadunits(nil);
  791. { has it been compiled at a higher level ?}
  792. if current_module.state=ms_compiled then
  793. begin
  794. Message1(parser_u_already_compiled,current_module.realmodulename^);
  795. exit;
  796. end;
  797. consume_semicolon_after_uses:=true;
  798. end
  799. else
  800. consume_semicolon_after_uses:=false;
  801. { move the global symtable from the temporary local to global }
  802. current_module.globalsymtable:=current_module.localsymtable;
  803. current_module.localsymtable:=nil;
  804. { number all units, so we know if a unit is used by this unit or
  805. needs to be added implicitly }
  806. current_module.updatemaps;
  807. { consume the semicolon after maps have been updated else conditional compiling expressions
  808. might cause internal errors, see tw8611 }
  809. if consume_semicolon_after_uses then
  810. consume(_SEMICOLON);
  811. { create whole program optimisation information (may already be
  812. updated in the interface, e.g., in case of classrefdef typed
  813. constants }
  814. current_module.wpoinfo:=tunitwpoinfo.create;
  815. { ... parse the declarations }
  816. Message1(parser_u_parsing_interface,current_module.realmodulename^);
  817. symtablestack.push(current_module.globalsymtable);
  818. {$ifdef jvm}
  819. { fake classdef to represent the class corresponding to the unit }
  820. addmoduleclass;
  821. {$endif}
  822. read_interface_declarations;
  823. { Export macros defined in the interface for macpas. The macros
  824. are put in the globalmacrosymtable that will only be used by other
  825. units. The current unit continues to use the localmacrosymtable }
  826. if (m_mac in current_settings.modeswitches) then
  827. begin
  828. current_module.globalmacrosymtable:=tmacrosymtable.create(true);
  829. current_module.localmacrosymtable.SymList.ForEachCall(@copy_macro,nil);
  830. end;
  831. { leave when we got an error }
  832. if (Errorcount>0) and not status.skip_error then
  833. begin
  834. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  835. status.skip_error:=true;
  836. symtablestack.pop(current_module.globalsymtable);
  837. exit;
  838. end;
  839. { Our interface is compiled, generate CRC and switch to implementation }
  840. if not(cs_compilesystem in current_settings.moduleswitches) and
  841. (Errorcount=0) then
  842. tppumodule(current_module).getppucrc;
  843. current_module.in_interface:=false;
  844. current_module.interface_compiled:=true;
  845. { First reload all units depending on our interface, we need to do this
  846. in the implementation part to prevent erroneous circular references }
  847. tppumodule(current_module).setdefgeneration;
  848. tppumodule(current_module).reload_flagged_units;
  849. { Parse the implementation section }
  850. if (m_mac in current_settings.modeswitches) and try_to_consume(_END) then
  851. current_module.interface_only:=true
  852. else
  853. current_module.interface_only:=false;
  854. parse_only:=false;
  855. { create static symbol table }
  856. current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
  857. { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
  858. maybe_load_got;
  859. if not current_module.interface_only then
  860. begin
  861. consume(_IMPLEMENTATION);
  862. Message1(unit_u_loading_implementation_units,current_module.modulename^);
  863. { Read the implementation units }
  864. if token=_USES then
  865. begin
  866. loadunits(current_module.globalsymtable);
  867. consume(_SEMICOLON);
  868. end;
  869. end;
  870. if current_module.state=ms_compiled then
  871. begin
  872. symtablestack.pop(current_module.globalsymtable);
  873. exit;
  874. end;
  875. { All units are read, now give them a number }
  876. current_module.updatemaps;
  877. { further, changing the globalsymtable is not allowed anymore }
  878. current_module.globalsymtable.sealed:=true;
  879. symtablestack.push(current_module.localsymtable);
  880. if not current_module.interface_only then
  881. begin
  882. Message1(parser_u_parsing_implementation,current_module.modulename^);
  883. if current_module.in_interface then
  884. internalerror(200212285);
  885. { Compile the unit }
  886. init_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'init'),potype_unitinit,current_module.localsymtable);
  887. init_procinfo.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
  888. init_procinfo.parse_body;
  889. { save file pos for debuginfo }
  890. current_module.mainfilepos:=init_procinfo.entrypos;
  891. end;
  892. { remove all units that we are waiting for that are already waiting for
  893. us => breaking up circles }
  894. for i:=0 to current_module.waitingunits.count-1 do
  895. for j:=current_module.waitingforunit.count-1 downto 0 do
  896. if current_module.waitingunits[i]=current_module.waitingforunit[j] then
  897. current_module.waitingforunit.delete(j);
  898. {$ifdef DEBUG_UNITWAITING}
  899. Writeln('Units waiting for ', current_module.modulename^, ': ',
  900. current_module.waitingforunit.Count);
  901. {$endif}
  902. result:=current_module.waitingforunit.count=0;
  903. { save all information that is needed for finishing the unit }
  904. New(finishstate);
  905. finishstate^.init_procinfo:=init_procinfo;
  906. current_module.finishstate:=finishstate;
  907. if result then
  908. finish_unit(current_module,true)
  909. else
  910. begin
  911. { save the current state, so the parsing can continue where we left
  912. of here }
  913. New(globalstate);
  914. save_global_state(globalstate^,true);
  915. current_module.globalstate:=globalstate;
  916. end;
  917. end;
  918. procedure finish_unit(module:tmodule;immediate:boolean);
  919. function is_assembler_generated:boolean;
  920. var
  921. hal : tasmlisttype;
  922. begin
  923. result:=false;
  924. if Errorcount=0 then
  925. begin
  926. for hal:=low(TasmlistType) to high(TasmlistType) do
  927. if not current_asmdata.asmlists[hal].empty then
  928. begin
  929. result:=true;
  930. exit;
  931. end;
  932. end;
  933. end;
  934. procedure module_is_done;inline;
  935. begin
  936. dispose(pglobalstate(current_module.globalstate));
  937. current_module.globalstate:=nil;
  938. dispose(pfinishstate(current_module.finishstate));
  939. current_module.finishstate:=nil;
  940. end;
  941. var
  942. {$ifdef EXTDEBUG}
  943. store_crc,
  944. {$endif EXTDEBUG}
  945. store_interface_crc,
  946. store_indirect_crc: cardinal;
  947. force_init_final : boolean;
  948. init_procinfo,
  949. finalize_procinfo : tcgprocinfo;
  950. i : longint;
  951. ag : boolean;
  952. finishstate : tfinishstate;
  953. globalstate : tglobalstate;
  954. waitingmodule : tmodule;
  955. begin
  956. fillchar(globalstate,sizeof(tglobalstate),0);
  957. if not immediate then
  958. begin
  959. {$ifdef DEBUG_UNITWAITING}
  960. writeln('finishing waiting unit ''', module.modulename^, '''');
  961. {$endif DEBUG_UNITWAITING}
  962. { restore the state when we stopped working on the unit }
  963. save_global_state(globalstate,true);
  964. if not assigned(module.globalstate) then
  965. internalerror(2012091802);
  966. restore_global_state(pglobalstate(module.globalstate)^,true);
  967. end;
  968. { current_module is now module }
  969. if not assigned(current_module.finishstate) then
  970. internalerror(2012091801);
  971. finishstate:=pfinishstate(current_module.finishstate)^;
  972. finalize_procinfo:=nil;
  973. init_procinfo:=finishstate.init_procinfo;
  974. { Generate specializations of objectdefs methods }
  975. generate_specialization_procs;
  976. { Generate VMTs }
  977. if Errorcount=0 then
  978. begin
  979. write_vmts(current_module.globalsymtable,true);
  980. write_vmts(current_module.localsymtable,false);
  981. end;
  982. { add implementations for synthetic method declarations added by
  983. the compiler }
  984. add_synthetic_method_implementations(current_module.globalsymtable);
  985. add_synthetic_method_implementations(current_module.localsymtable);
  986. { if the unit contains ansi/widestrings, initialization and
  987. finalization code must be forced }
  988. force_init_final:=tglobalsymtable(current_module.globalsymtable).needs_init_final or
  989. tstaticsymtable(current_module.localsymtable).needs_init_final;
  990. { should we force unit initialization? }
  991. { this is a hack, but how can it be done better ? }
  992. { Now the sole purpose of this is to change 'init' to 'init_implicit',
  993. is it needed at all? (Sergei) }
  994. { it's needed in case cnodeutils.force_init = true }
  995. if (force_init_final or cnodeutils.force_init) and
  996. assigned(init_procinfo) and
  997. has_no_code(init_procinfo.code) then
  998. begin
  999. { first release the not used init procinfo }
  1000. if assigned(init_procinfo) then
  1001. release_main_proc(init_procinfo);
  1002. init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable);
  1003. end;
  1004. { finalize? }
  1005. if not current_module.interface_only and (token=_FINALIZATION) then
  1006. begin
  1007. { Compile the finalize }
  1008. finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
  1009. finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
  1010. finalize_procinfo.parse_body;
  1011. end
  1012. else if force_init_final or cnodeutils.force_final then
  1013. finalize_procinfo:=gen_implicit_initfinal(uf_finalize,current_module.localsymtable);
  1014. { Now both init and finalize bodies are read and it is known
  1015. which variables are used in both init and finalize we can now
  1016. generate the code. This is required to prevent putting a variable in
  1017. a register that is also used in the finalize body (PFV) }
  1018. if assigned(init_procinfo) then
  1019. begin
  1020. if (force_init_final or cnodeutils.force_init) or
  1021. not(has_no_code(init_procinfo.code)) then
  1022. begin
  1023. init_procinfo.code:=cnodeutils.wrap_proc_body(init_procinfo.procdef,init_procinfo.code);
  1024. init_procinfo.generate_code;
  1025. current_module.flags:=current_module.flags or uf_init;
  1026. end;
  1027. init_procinfo.resetprocdef;
  1028. release_main_proc(init_procinfo);
  1029. end;
  1030. if assigned(finalize_procinfo) then
  1031. begin
  1032. if force_init_final or
  1033. cnodeutils.force_init or
  1034. not(has_no_code(finalize_procinfo.code)) then
  1035. begin
  1036. finalize_procinfo.code:=cnodeutils.wrap_proc_body(finalize_procinfo.procdef,finalize_procinfo.code);
  1037. finalize_procinfo.generate_code;
  1038. current_module.flags:=current_module.flags or uf_finalize;
  1039. end;
  1040. finalize_procinfo.resetprocdef;
  1041. release_main_proc(finalize_procinfo);
  1042. end;
  1043. symtablestack.pop(current_module.localsymtable);
  1044. symtablestack.pop(current_module.globalsymtable);
  1045. { the last char should always be a point }
  1046. consume(_POINT);
  1047. { reset wpo flags for all defs }
  1048. reset_all_defs;
  1049. if (Errorcount=0) then
  1050. begin
  1051. { tests, if all (interface) forwards are resolved }
  1052. tstoredsymtable(current_module.globalsymtable).check_forwards;
  1053. { check if all private fields are used }
  1054. tstoredsymtable(current_module.globalsymtable).allprivatesused;
  1055. { test static symtable }
  1056. tstoredsymtable(current_module.localsymtable).allsymbolsused;
  1057. tstoredsymtable(current_module.localsymtable).allprivatesused;
  1058. tstoredsymtable(current_module.localsymtable).check_forwards;
  1059. tstoredsymtable(current_module.localsymtable).checklabels;
  1060. { used units }
  1061. current_module.allunitsused;
  1062. end;
  1063. { leave when we got an error }
  1064. if (Errorcount>0) and not status.skip_error then
  1065. begin
  1066. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1067. status.skip_error:=true;
  1068. module_is_done;
  1069. if not immediate then
  1070. restore_global_state(globalstate,true);
  1071. exit;
  1072. end;
  1073. { if an Objective-C module, generate rtti and module info }
  1074. MaybeGenerateObjectiveCImageInfo(current_module.globalsymtable,current_module.localsymtable);
  1075. { do we need to add the variants unit? }
  1076. maybeloadvariantsunit;
  1077. { generate rtti/init tables }
  1078. write_persistent_type_info(current_module.globalsymtable,true);
  1079. write_persistent_type_info(current_module.localsymtable,false);
  1080. { Tables }
  1081. cnodeutils.InsertThreadvars;
  1082. { Resource strings }
  1083. GenerateResourceStrings;
  1084. { Widestring typed constants }
  1085. cnodeutils.InsertWideInits;
  1086. { Resourcestring references }
  1087. cnodeutils.InsertResStrInits;
  1088. { generate debuginfo }
  1089. if (cs_debuginfo in current_settings.moduleswitches) then
  1090. current_debuginfo.inserttypeinfo;
  1091. { generate imports }
  1092. if current_module.ImportLibraryList.Count>0 then
  1093. importlib.generatelib;
  1094. { insert own objectfile, or say that it's in a library
  1095. (no check for an .o when loading) }
  1096. ag:=is_assembler_generated;
  1097. if ag then
  1098. insertobjectfile
  1099. else
  1100. begin
  1101. current_module.flags:=current_module.flags or uf_no_link;
  1102. current_module.flags:=current_module.flags and not (uf_has_stabs_debuginfo or uf_has_dwarf_debuginfo);
  1103. end;
  1104. if ag then
  1105. begin
  1106. { create callframe info }
  1107. create_dwarf_frame;
  1108. { assemble }
  1109. create_objectfile;
  1110. end;
  1111. { Write out the ppufile after the object file has been created }
  1112. store_interface_crc:=current_module.interface_crc;
  1113. store_indirect_crc:=current_module.indirect_crc;
  1114. {$ifdef EXTDEBUG}
  1115. store_crc:=current_module.crc;
  1116. {$endif EXTDEBUG}
  1117. if (Errorcount=0) then
  1118. tppumodule(current_module).writeppu;
  1119. if not(cs_compilesystem in current_settings.moduleswitches) then
  1120. begin
  1121. if store_interface_crc<>current_module.interface_crc then
  1122. Message1(unit_u_interface_crc_changed,current_module.ppufilename);
  1123. if store_indirect_crc<>current_module.indirect_crc then
  1124. Message1(unit_u_indirect_crc_changed,current_module.ppufilename);
  1125. end;
  1126. {$ifdef EXTDEBUG}
  1127. if not(cs_compilesystem in current_settings.moduleswitches) then
  1128. if (store_crc<>current_module.crc) then
  1129. Message1(unit_u_implementation_crc_changed,current_module.ppufilename);
  1130. {$endif EXTDEBUG}
  1131. { release unregistered defs/syms from the localsymtable }
  1132. free_unregistered_localsymtable_elements;
  1133. { release local symtables that are not needed anymore }
  1134. free_localsymtables(current_module.globalsymtable);
  1135. free_localsymtables(current_module.localsymtable);
  1136. { leave when we got an error }
  1137. if (Errorcount>0) and not status.skip_error then
  1138. begin
  1139. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1140. status.skip_error:=true;
  1141. module_is_done;
  1142. if not immediate then
  1143. restore_global_state(globalstate,true);
  1144. exit;
  1145. end;
  1146. {$ifdef debug_devirt}
  1147. { print out all instantiated class/object types }
  1148. writeln('constructed object/class/classreftypes in ',current_module.realmodulename^);
  1149. for i := 0 to current_module.wpoinfo.createdobjtypes.count-1 do
  1150. begin
  1151. write(' ',tdef(current_module.wpoinfo.createdobjtypes[i]).GetTypeName);
  1152. case tdef(current_module.wpoinfo.createdobjtypes[i]).typ of
  1153. objectdef:
  1154. case tobjectdef(current_module.wpoinfo.createdobjtypes[i]).objecttype of
  1155. odt_object:
  1156. writeln(' (object)');
  1157. odt_class:
  1158. writeln(' (class)');
  1159. else
  1160. internalerror(2008101103);
  1161. end;
  1162. else
  1163. internalerror(2008101104);
  1164. end;
  1165. end;
  1166. for i := 0 to current_module.wpoinfo.createdclassrefobjtypes.count-1 do
  1167. begin
  1168. write(' Class Of ',tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).GetTypeName);
  1169. case tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).typ of
  1170. objectdef:
  1171. case tobjectdef(current_module.wpoinfo.createdclassrefobjtypes[i]).objecttype of
  1172. odt_class:
  1173. writeln(' (classrefdef)');
  1174. else
  1175. internalerror(2008101105);
  1176. end
  1177. else
  1178. internalerror(2008101102);
  1179. end;
  1180. end;
  1181. {$endif debug_devirt}
  1182. Message1(unit_u_finished_compiling,current_module.modulename^);
  1183. module_is_done;
  1184. if not immediate then
  1185. restore_global_state(globalstate,true);
  1186. for i:=0 to module.waitingunits.count-1 do
  1187. begin
  1188. waitingmodule:=tmodule(module.waitingunits[i]);
  1189. waitingmodule.waitingforunit.remove(module);
  1190. { only finish the module if it isn't already finished }
  1191. if (waitingmodule.waitingforunit.count=0) and
  1192. assigned(waitingmodule.finishstate) then
  1193. begin
  1194. finish_unit(waitingmodule,false);
  1195. waitingmodule.end_of_parsing;
  1196. end;
  1197. end;
  1198. end;
  1199. procedure procexport(const s : string);
  1200. var
  1201. hp : texported_item;
  1202. begin
  1203. hp:=texported_item.create;
  1204. hp.name:=stringdup(s);
  1205. hp.options:=hp.options or eo_name;
  1206. exportlib.exportprocedure(hp);
  1207. end;
  1208. procedure varexport(const s : string);
  1209. var
  1210. hp : texported_item;
  1211. begin
  1212. hp:=texported_item.create;
  1213. hp.name:=stringdup(s);
  1214. hp.options:=hp.options or eo_name;
  1215. exportlib.exportvar(hp);
  1216. end;
  1217. procedure insert_export(sym : TObject;arg:pointer);
  1218. var
  1219. i : longint;
  1220. item : TCmdStrListItem;
  1221. begin
  1222. case TSym(sym).typ of
  1223. { ignore: }
  1224. unitsym,
  1225. syssym,
  1226. constsym,
  1227. enumsym,
  1228. typesym:
  1229. ;
  1230. procsym:
  1231. begin
  1232. for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
  1233. begin
  1234. if not(tprocdef(tprocsym(sym).ProcdefList[i]).proccalloption in [pocall_internproc]) and
  1235. ((tprocdef(tprocsym(sym).ProcdefList[i]).procoptions*[po_external])=[]) and
  1236. ((tsymtable(arg).symtabletype=globalsymtable) or
  1237. ((tsymtable(arg).symtabletype=staticsymtable) and (po_public in tprocdef(tprocsym(sym).ProcdefList[i]).procoptions))
  1238. ) then
  1239. begin
  1240. procexport(tprocdef(tprocsym(sym).ProcdefList[i]).mangledname);
  1241. { walk through all aliases }
  1242. item:=TCmdStrListItem(tprocdef(tprocsym(sym).ProcdefList[i]).aliasnames.first);
  1243. while assigned(item) do
  1244. begin
  1245. { avoid duplicate entries, sometimes aliasnames contains the mangledname }
  1246. if item.str<>tprocdef(tprocsym(sym).ProcdefList[i]).mangledname then
  1247. procexport(item.str);
  1248. item:=TCmdStrListItem(item.next);
  1249. end;
  1250. end;
  1251. end;
  1252. end;
  1253. staticvarsym:
  1254. begin
  1255. varexport(tsym(sym).mangledname);
  1256. end;
  1257. else
  1258. begin
  1259. writeln('unknown: ',ord(TSym(sym).typ));
  1260. end;
  1261. end;
  1262. end;
  1263. Function RewritePPU(const PPUFn,PPLFn:String):Boolean;
  1264. Var
  1265. MakeStatic : Boolean;
  1266. Var
  1267. buffer : array[0..$1fff] of byte;
  1268. inppu,
  1269. outppu : tppufile;
  1270. b,
  1271. untilb : byte;
  1272. l,m : longint;
  1273. f : file;
  1274. ext,
  1275. s : string;
  1276. ppuversion : dword;
  1277. begin
  1278. Result:=false;
  1279. MakeStatic:=False;
  1280. inppu:=tppufile.create(PPUFn);
  1281. if not inppu.openfile then
  1282. begin
  1283. inppu.free;
  1284. Comment(V_Error,'Could not open : '+PPUFn);
  1285. Exit;
  1286. end;
  1287. { Check the ppufile }
  1288. if not inppu.CheckPPUId then
  1289. begin
  1290. inppu.free;
  1291. Comment(V_Error,'Not a PPU File : '+PPUFn);
  1292. Exit;
  1293. end;
  1294. ppuversion:=inppu.GetPPUVersion;
  1295. if ppuversion<CurrentPPUVersion then
  1296. begin
  1297. inppu.free;
  1298. Comment(V_Error,'Wrong PPU Version '+tostr(ppuversion)+' in '+PPUFn);
  1299. Exit;
  1300. end;
  1301. { No .o file generated for this ppu, just skip }
  1302. if (inppu.header.flags and uf_no_link)<>0 then
  1303. begin
  1304. inppu.free;
  1305. Result:=true;
  1306. Exit;
  1307. end;
  1308. { Already a lib? }
  1309. if (inppu.header.flags and uf_in_library)<>0 then
  1310. begin
  1311. inppu.free;
  1312. Comment(V_Error,'PPU is already in a library : '+PPUFn);
  1313. Exit;
  1314. end;
  1315. { We need a static linked unit }
  1316. if (inppu.header.flags and uf_static_linked)=0 then
  1317. begin
  1318. inppu.free;
  1319. Comment(V_Error,'PPU is not static linked : '+PPUFn);
  1320. Exit;
  1321. end;
  1322. { Check if shared is allowed }
  1323. if tsystem(inppu.header.target) in [system_i386_go32v2] then
  1324. begin
  1325. Comment(V_Error,'Shared library not supported for ppu target, switching to static library');
  1326. MakeStatic:=true;
  1327. end;
  1328. { Create the new ppu }
  1329. if PPUFn=PPLFn then
  1330. outppu:=tppufile.create('ppumove.$$$')
  1331. else
  1332. outppu:=tppufile.create(PPLFn);
  1333. outppu.createfile;
  1334. { Create new header, with the new flags }
  1335. outppu.header:=inppu.header;
  1336. outppu.header.flags:=outppu.header.flags or uf_in_library;
  1337. if MakeStatic then
  1338. outppu.header.flags:=outppu.header.flags or uf_static_linked
  1339. else
  1340. outppu.header.flags:=outppu.header.flags or uf_shared_linked;
  1341. { read until the object files are found }
  1342. untilb:=iblinkunitofiles;
  1343. repeat
  1344. b:=inppu.readentry;
  1345. if b in [ibendinterface,ibend] then
  1346. begin
  1347. inppu.free;
  1348. outppu.free;
  1349. Comment(V_Error,'No files to be linked found : '+PPUFn);
  1350. Exit;
  1351. end;
  1352. if b<>untilb then
  1353. begin
  1354. repeat
  1355. inppu.getdatabuf(buffer,sizeof(buffer),l);
  1356. outppu.putdata(buffer,l);
  1357. until l<sizeof(buffer);
  1358. outppu.writeentry(b);
  1359. end;
  1360. until (b=untilb);
  1361. { we have now reached the section for the files which need to be added,
  1362. now add them to the list }
  1363. case b of
  1364. iblinkunitofiles :
  1365. begin
  1366. { add all o files, and save the entry when not creating a static
  1367. library to keep staticlinking possible }
  1368. while not inppu.endofentry do
  1369. begin
  1370. s:=inppu.getstring;
  1371. m:=inppu.getlongint;
  1372. if not MakeStatic then
  1373. begin
  1374. outppu.putstring(s);
  1375. outppu.putlongint(m);
  1376. end;
  1377. current_module.linkotherofiles.add(s,link_always);;
  1378. end;
  1379. if not MakeStatic then
  1380. outppu.writeentry(b);
  1381. end;
  1382. { iblinkunitstaticlibs :
  1383. begin
  1384. AddToLinkFiles(ExtractLib(inppu.getstring));
  1385. if not inppu.endofentry then
  1386. begin
  1387. repeat
  1388. inppu.getdatabuf(buffer^,bufsize,l);
  1389. outppu.putdata(buffer^,l);
  1390. until l<bufsize;
  1391. outppu.writeentry(b);
  1392. end;
  1393. end; }
  1394. end;
  1395. { just add a new entry with the new lib }
  1396. if MakeStatic then
  1397. begin
  1398. outppu.putstring('imp'+current_module.realmodulename^);
  1399. outppu.putlongint(link_static);
  1400. outppu.writeentry(iblinkunitstaticlibs)
  1401. end
  1402. else
  1403. begin
  1404. outppu.putstring('imp'+current_module.realmodulename^);
  1405. outppu.putlongint(link_shared);
  1406. outppu.writeentry(iblinkunitsharedlibs);
  1407. end;
  1408. { read all entries until the end and write them also to the new ppu }
  1409. repeat
  1410. b:=inppu.readentry;
  1411. { don't write ibend, that's written automatically }
  1412. if b<>ibend then
  1413. begin
  1414. if b=iblinkothersharedlibs then
  1415. begin
  1416. while not inppu.endofentry do
  1417. begin
  1418. s:=inppu.getstring;
  1419. m:=inppu.getlongint;
  1420. outppu.putstring(s);
  1421. outppu.putlongint(m);
  1422. { strip lib prefix }
  1423. if copy(s,1,3)='lib' then
  1424. delete(s,1,3);
  1425. ext:=ExtractFileExt(s);
  1426. if ext<>'' then
  1427. delete(s,length(s)-length(ext)+1,length(ext));
  1428. current_module.linkOtherSharedLibs.add(s,link_always);
  1429. end;
  1430. end
  1431. else
  1432. repeat
  1433. inppu.getdatabuf(buffer,sizeof(buffer),l);
  1434. outppu.putdata(buffer,l);
  1435. until l<sizeof(buffer);
  1436. outppu.writeentry(b);
  1437. end;
  1438. until b=ibend;
  1439. { write the last stuff and close }
  1440. outppu.flush;
  1441. outppu.writeheader;
  1442. outppu.free;
  1443. inppu.free;
  1444. { rename }
  1445. if PPUFn=PPLFn then
  1446. begin
  1447. {$push}{$I-}
  1448. assign(f,PPUFn);
  1449. erase(f);
  1450. assign(f,'ppumove.$$$');
  1451. rename(f,PPUFn);
  1452. {$pop}
  1453. if ioresult<>0 then;
  1454. end;
  1455. Result:=True;
  1456. end;
  1457. procedure createimportlibfromexports;
  1458. var
  1459. hp : texported_item;
  1460. begin
  1461. hp:=texported_item(current_module._exports.first);
  1462. while assigned(hp) do
  1463. begin
  1464. current_module.AddExternalImport(current_module.realmodulename^,hp.name^,hp.name^,hp.index,hp.is_var,false);
  1465. hp:=texported_item(hp.next);
  1466. end;
  1467. end;
  1468. procedure proc_package;
  1469. var
  1470. main_file : tinputfile;
  1471. hp,hp2 : tmodule;
  1472. {finalize_procinfo,
  1473. init_procinfo,
  1474. main_procinfo : tcgprocinfo;}
  1475. force_init_final : boolean;
  1476. uu : tused_unit;
  1477. module_name: ansistring;
  1478. begin
  1479. Status.IsPackage:=true;
  1480. Status.IsExe:=true;
  1481. parse_only:=false;
  1482. {main_procinfo:=nil;
  1483. init_procinfo:=nil;
  1484. finalize_procinfo:=nil;}
  1485. if not RelocSectionSetExplicitly then
  1486. RelocSection:=true;
  1487. { Relocation works only without stabs under Windows when }
  1488. { external linker (LD) is used. LD generates relocs for }
  1489. { stab sections which is not loaded in memory. It causes }
  1490. { AV error when DLL is loaded and relocation is needed. }
  1491. { Internal linker does not have this problem. }
  1492. if RelocSection and
  1493. (target_info.system in systems_all_windows+[system_i386_wdosx]) and
  1494. (cs_link_extern in current_settings.globalswitches) then
  1495. begin
  1496. include(current_settings.globalswitches,cs_link_strip);
  1497. { Warning stabs info does not work with reloc section !! }
  1498. if (cs_debuginfo in current_settings.moduleswitches) and
  1499. (target_dbg.id=dbg_stabs) then
  1500. begin
  1501. Message1(parser_w_parser_reloc_no_debug,current_module.mainsource);
  1502. Message(parser_w_parser_win32_debug_needs_WN);
  1503. exclude(current_settings.moduleswitches,cs_debuginfo);
  1504. end;
  1505. end;
  1506. { get correct output names }
  1507. main_file := current_scanner.inputfile;
  1508. while assigned(main_file.next) do
  1509. main_file := main_file.next;
  1510. current_module.SetFileName(main_file.path+main_file.name,true);
  1511. { consume _PACKAGE word }
  1512. consume(_ID);
  1513. module_name:=orgpattern;
  1514. consume(_ID);
  1515. while token=_POINT do
  1516. begin
  1517. consume(_POINT);
  1518. module_name:=module_name+'.'+orgpattern;
  1519. consume(_ID);
  1520. end;
  1521. current_module.setmodulename(module_name);
  1522. current_module.ispackage:=true;
  1523. exportlib.preparelib(module_name);
  1524. if tf_library_needs_pic in target_info.flags then
  1525. include(current_settings.moduleswitches,cs_create_pic);
  1526. { setup things using the switches, do this before the semicolon, because after the semicolon has been
  1527. read, all following directives are parsed as well }
  1528. setupglobalswitches;
  1529. consume(_SEMICOLON);
  1530. { global switches are read, so further changes aren't allowed }
  1531. current_module.in_global:=false;
  1532. { set implementation flag }
  1533. current_module.in_interface:=false;
  1534. current_module.interface_compiled:=true;
  1535. { insert after the unit symbol tables the static symbol table }
  1536. { of the program }
  1537. current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
  1538. {Load the units used by the program we compile.}
  1539. if token=_REQUIRES then
  1540. begin
  1541. end;
  1542. {Load the units used by the program we compile.}
  1543. if (token=_ID) and (idtoken=_CONTAINS) then
  1544. begin
  1545. { consume _CONTAINS word }
  1546. consume(_ID);
  1547. while true do
  1548. begin
  1549. if token=_ID then
  1550. begin
  1551. module_name:=pattern;
  1552. consume(_ID);
  1553. while token=_POINT do
  1554. begin
  1555. consume(_POINT);
  1556. module_name:=module_name+'.'+orgpattern;
  1557. consume(_ID);
  1558. end;
  1559. AddUnit(module_name);
  1560. end
  1561. else
  1562. consume(_ID);
  1563. if token=_COMMA then
  1564. consume(_COMMA)
  1565. else break;
  1566. end;
  1567. consume(_SEMICOLON);
  1568. end;
  1569. { All units are read, now give them a number }
  1570. current_module.updatemaps;
  1571. {Insert the name of the main program into the symbol table.}
  1572. if current_module.realmodulename^<>'' then
  1573. tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
  1574. Message1(parser_u_parsing_implementation,current_module.mainsource);
  1575. symtablestack.push(current_module.localsymtable);
  1576. { create whole program optimisation information }
  1577. current_module.wpoinfo:=tunitwpoinfo.create;
  1578. { should we force unit initialization? }
  1579. force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
  1580. if force_init_final or cnodeutils.force_init then
  1581. {init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable)};
  1582. { Add symbol to the exports section for win32 so smartlinking a
  1583. DLL will include the edata section }
  1584. if assigned(exportlib) and
  1585. (target_info.system in [system_i386_win32,system_i386_wdosx]) and
  1586. ((current_module.flags and uf_has_exports)<>0) then
  1587. current_asmdata.asmlists[al_procedures].concat(tai_const.createname(make_mangledname('EDATA',current_module.localsymtable,''),0));
  1588. { all labels must be defined before generating code }
  1589. if Errorcount=0 then
  1590. tstoredsymtable(current_module.localsymtable).checklabels;
  1591. symtablestack.pop(current_module.localsymtable);
  1592. { consume the last point }
  1593. consume(_END);
  1594. consume(_POINT);
  1595. if (Errorcount=0) then
  1596. begin
  1597. { test static symtable }
  1598. tstoredsymtable(current_module.localsymtable).allsymbolsused;
  1599. tstoredsymtable(current_module.localsymtable).allprivatesused;
  1600. tstoredsymtable(current_module.localsymtable).check_forwards;
  1601. current_module.allunitsused;
  1602. end;
  1603. new_section(current_asmdata.asmlists[al_globals],sec_data,'_FPCDummy',4);
  1604. current_asmdata.asmlists[al_globals].concat(tai_symbol.createname_global('_FPCDummy',AT_DATA,0));
  1605. current_asmdata.asmlists[al_globals].concat(tai_const.create_32bit(0));
  1606. new_section(current_asmdata.asmlists[al_procedures],sec_code,'',0);
  1607. current_asmdata.asmlists[al_procedures].concat(tai_symbol.createname_global('_DLLMainCRTStartup',AT_FUNCTION,0));
  1608. gen_fpc_dummy(current_asmdata.asmlists[al_procedures]);
  1609. current_asmdata.asmlists[al_procedures].concat(tai_const.createname('_FPCDummy',0));
  1610. { leave when we got an error }
  1611. if (Errorcount>0) and not status.skip_error then
  1612. begin
  1613. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1614. status.skip_error:=true;
  1615. exit;
  1616. end;
  1617. { remove all unused units, this happends when units are removed
  1618. from the uses clause in the source and the ppu was already being loaded }
  1619. hp:=tmodule(loaded_units.first);
  1620. while assigned(hp) do
  1621. begin
  1622. hp2:=hp;
  1623. hp:=tmodule(hp.next);
  1624. if hp2.is_unit and
  1625. not assigned(hp2.globalsymtable) then
  1626. loaded_units.remove(hp2);
  1627. end;
  1628. { force exports }
  1629. uu:=tused_unit(usedunits.first);
  1630. while assigned(uu) do
  1631. begin
  1632. uu.u.globalsymtable.symlist.ForEachCall(@insert_export,uu.u.globalsymtable);
  1633. { check localsymtable for exports too to get public symbols }
  1634. uu.u.localsymtable.symlist.ForEachCall(@insert_export,uu.u.localsymtable);
  1635. { create special exports }
  1636. if (uu.u.flags and uf_init)<>0 then
  1637. procexport(make_mangledname('INIT$',uu.u.globalsymtable,''));
  1638. if (uu.u.flags and uf_finalize)<>0 then
  1639. procexport(make_mangledname('FINALIZE$',uu.u.globalsymtable,''));
  1640. if (uu.u.flags and uf_threadvars)=uf_threadvars then
  1641. varexport(make_mangledname('THREADVARLIST',uu.u.globalsymtable,''));
  1642. uu:=tused_unit(uu.next);
  1643. end;
  1644. {$ifdef arm}
  1645. { Insert .pdata section for arm-wince.
  1646. It is needed for exception handling. }
  1647. if target_info.system in [system_arm_wince] then
  1648. InsertPData;
  1649. {$endif arm}
  1650. { generate debuginfo }
  1651. if (cs_debuginfo in current_settings.moduleswitches) then
  1652. current_debuginfo.inserttypeinfo;
  1653. exportlib.generatelib;
  1654. { write all our exports to the import library,
  1655. needs to be done after exportlib.generatelib; }
  1656. createimportlibfromexports;
  1657. { generate imports }
  1658. if current_module.ImportLibraryList.Count>0 then
  1659. importlib.generatelib;
  1660. { Reference all DEBUGINFO sections from the main .fpc section }
  1661. if (cs_debuginfo in current_settings.moduleswitches) then
  1662. current_debuginfo.referencesections(current_asmdata.asmlists[al_procedures]);
  1663. { insert own objectfile }
  1664. insertobjectfile;
  1665. { assemble and link }
  1666. create_objectfile;
  1667. { We might need the symbols info if not using
  1668. the default do_extractsymbolinfo
  1669. which is a dummy function PM }
  1670. needsymbolinfo:=do_extractsymbolinfo<>@def_extractsymbolinfo;
  1671. { release all local symtables that are not needed anymore }
  1672. if (not needsymbolinfo) then
  1673. free_localsymtables(current_module.localsymtable);
  1674. { leave when we got an error }
  1675. if (Errorcount>0) and not status.skip_error then
  1676. begin
  1677. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1678. status.skip_error:=true;
  1679. exit;
  1680. end;
  1681. if (not current_module.is_unit) then
  1682. begin
  1683. { finally rewrite all units included into the package }
  1684. uu:=tused_unit(usedunits.first);
  1685. while assigned(uu) do
  1686. begin
  1687. RewritePPU(uu.u.ppufilename,uu.u.ppufilename);
  1688. uu:=tused_unit(uu.next);
  1689. end;
  1690. { create the executable when we are at level 1 }
  1691. if (compile_level=1) then
  1692. begin
  1693. { create global resource file by collecting all resource files }
  1694. CollectResourceFiles;
  1695. { write .def file }
  1696. if (cs_link_deffile in current_settings.globalswitches) then
  1697. deffile.writefile;
  1698. { insert all .o files from all loaded units and
  1699. unload the units, we don't need them anymore.
  1700. Keep the current_module because that is still needed }
  1701. hp:=tmodule(loaded_units.first);
  1702. while assigned(hp) do
  1703. begin
  1704. { the package itself contains no code so far }
  1705. linker.AddModuleFiles(hp);
  1706. hp2:=tmodule(hp.next);
  1707. if (hp<>current_module) and
  1708. (not needsymbolinfo) then
  1709. begin
  1710. loaded_units.remove(hp);
  1711. hp.free;
  1712. end;
  1713. hp:=hp2;
  1714. end;
  1715. linker.MakeSharedLibrary
  1716. end;
  1717. { Give Fatal with error count for linker errors }
  1718. if (Errorcount>0) and not status.skip_error then
  1719. begin
  1720. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1721. status.skip_error:=true;
  1722. end;
  1723. end;
  1724. end;
  1725. procedure proc_program(islibrary : boolean);
  1726. type
  1727. TProgramParam = record
  1728. name : ansistring;
  1729. nr : dword;
  1730. end;
  1731. var
  1732. main_file : tinputfile;
  1733. hp,hp2 : tmodule;
  1734. finalize_procinfo,
  1735. init_procinfo,
  1736. main_procinfo : tcgprocinfo;
  1737. force_init_final : boolean;
  1738. resources_used : boolean;
  1739. program_name : ansistring;
  1740. consume_semicolon_after_uses : boolean;
  1741. ps : tprogramparasym;
  1742. paramnum : longint;
  1743. textsym : ttypesym;
  1744. sc : array of TProgramParam;
  1745. i : Longint;
  1746. begin
  1747. DLLsource:=islibrary;
  1748. Status.IsLibrary:=IsLibrary;
  1749. Status.IsPackage:=false;
  1750. Status.IsExe:=true;
  1751. parse_only:=false;
  1752. main_procinfo:=nil;
  1753. init_procinfo:=nil;
  1754. finalize_procinfo:=nil;
  1755. resources_used:=false;
  1756. { make the compiler happy and avoid an uninitialized variable warning on Setlength(sc,length(sc)+1); }
  1757. sc:=nil;
  1758. { DLL defaults to create reloc info }
  1759. if islibrary then
  1760. begin
  1761. if not RelocSectionSetExplicitly then
  1762. RelocSection:=true;
  1763. end;
  1764. { Relocation works only without stabs under Windows when }
  1765. { external linker (LD) is used. LD generates relocs for }
  1766. { stab sections which is not loaded in memory. It causes }
  1767. { AV error when DLL is loaded and relocation is needed. }
  1768. { Internal linker does not have this problem. }
  1769. if RelocSection and
  1770. (target_info.system in systems_all_windows+[system_i386_wdosx]) and
  1771. (cs_link_extern in current_settings.globalswitches) then
  1772. begin
  1773. include(current_settings.globalswitches,cs_link_strip);
  1774. { Warning stabs info does not work with reloc section !! }
  1775. if (cs_debuginfo in current_settings.moduleswitches) and
  1776. (target_dbg.id=dbg_stabs) then
  1777. begin
  1778. Message1(parser_w_parser_reloc_no_debug,current_module.mainsource);
  1779. Message(parser_w_parser_win32_debug_needs_WN);
  1780. exclude(current_settings.moduleswitches,cs_debuginfo);
  1781. end;
  1782. end;
  1783. { get correct output names }
  1784. main_file := current_scanner.inputfile;
  1785. while assigned(main_file.next) do
  1786. main_file := main_file.next;
  1787. current_module.SetFileName(main_file.path+main_file.name,true);
  1788. if islibrary then
  1789. begin
  1790. consume(_LIBRARY);
  1791. program_name:=orgpattern;
  1792. consume(_ID);
  1793. while token=_POINT do
  1794. begin
  1795. consume(_POINT);
  1796. program_name:=program_name+'.'+orgpattern;
  1797. consume(_ID);
  1798. end;
  1799. current_module.setmodulename(program_name);
  1800. current_module.islibrary:=true;
  1801. exportlib.preparelib(program_name);
  1802. if tf_library_needs_pic in target_info.flags then
  1803. begin
  1804. include(current_settings.moduleswitches,cs_create_pic);
  1805. { also set create_pic for all unit compilation }
  1806. include(init_settings.moduleswitches,cs_create_pic);
  1807. end;
  1808. { setup things using the switches, do this before the semicolon, because after the semicolon has been
  1809. read, all following directives are parsed as well }
  1810. setupglobalswitches;
  1811. consume(_SEMICOLON);
  1812. end
  1813. else
  1814. { is there an program head ? }
  1815. if token=_PROGRAM then
  1816. begin
  1817. consume(_PROGRAM);
  1818. program_name:=orgpattern;
  1819. consume(_ID);
  1820. while token=_POINT do
  1821. begin
  1822. consume(_POINT);
  1823. program_name:=program_name+'.'+orgpattern;
  1824. consume(_ID);
  1825. end;
  1826. current_module.setmodulename(program_name);
  1827. if (target_info.system in systems_unit_program_exports) then
  1828. exportlib.preparelib(program_name);
  1829. if token=_LKLAMMER then
  1830. begin
  1831. consume(_LKLAMMER);
  1832. paramnum:=1;
  1833. repeat
  1834. if m_iso in current_settings.modeswitches then
  1835. begin
  1836. if (pattern<>'INPUT') and (pattern<>'OUTPUT') then
  1837. begin
  1838. { the symtablestack is not setup here, so text must be created later on }
  1839. Setlength(sc,length(sc)+1);
  1840. with sc[high(sc)] do
  1841. begin
  1842. name:=pattern;
  1843. nr:=paramnum;
  1844. end;
  1845. inc(paramnum);
  1846. end;
  1847. end;
  1848. consume(_ID);
  1849. until not try_to_consume(_COMMA);
  1850. consume(_RKLAMMER);
  1851. end;
  1852. { setup things using the switches, do this before the semicolon, because after the semicolon has been
  1853. read, all following directives are parsed as well }
  1854. setupglobalswitches;
  1855. consume(_SEMICOLON);
  1856. end
  1857. else
  1858. begin
  1859. if (target_info.system in systems_unit_program_exports) then
  1860. exportlib.preparelib(current_module.realmodulename^);
  1861. { setup things using the switches }
  1862. setupglobalswitches;
  1863. end;
  1864. { global switches are read, so further changes aren't allowed }
  1865. current_module.in_global:=false;
  1866. { set implementation flag }
  1867. current_module.in_interface:=false;
  1868. current_module.interface_compiled:=true;
  1869. { insert after the unit symbol tables the static symbol table
  1870. of the program }
  1871. current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
  1872. { load standard units (system,objpas,profile unit) }
  1873. loaddefaultunits;
  1874. { Load units provided on the command line }
  1875. loadautounits;
  1876. { insert iso program parameters }
  1877. if length(sc)>0 then
  1878. begin
  1879. textsym:=search_system_type('TEXT');
  1880. if not(assigned(textsym)) then
  1881. internalerror(2013011201);
  1882. for i:=0 to high(sc) do
  1883. begin
  1884. ps:=cprogramparasym.create(sc[i].name,sc[i].nr);
  1885. current_module.localsymtable.insert(ps,true);
  1886. end;
  1887. end;
  1888. { Load the units used by the program we compile. }
  1889. if token=_USES then
  1890. begin
  1891. loadunits(nil);
  1892. consume_semicolon_after_uses:=true;
  1893. end
  1894. else
  1895. consume_semicolon_after_uses:=false;
  1896. { All units are read, now give them a number }
  1897. current_module.updatemaps;
  1898. { consume the semicolon after maps have been updated else conditional compiling expressions
  1899. might cause internal errors, see tw8611 }
  1900. if consume_semicolon_after_uses then
  1901. consume(_SEMICOLON);
  1902. {Insert the name of the main program into the symbol table.}
  1903. if current_module.realmodulename^<>'' then
  1904. tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
  1905. Message1(parser_u_parsing_implementation,current_module.mainsource);
  1906. symtablestack.push(current_module.localsymtable);
  1907. {$ifdef jvm}
  1908. { fake classdef to represent the class corresponding to the unit }
  1909. addmoduleclass;
  1910. {$endif}
  1911. { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
  1912. maybe_load_got;
  1913. { create whole program optimisation information }
  1914. current_module.wpoinfo:=tunitwpoinfo.create;
  1915. { The program intialization needs an alias, so it can be called
  1916. from the bootstrap code.}
  1917. if islibrary then
  1918. begin
  1919. main_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,mainaliasname),potype_proginit,current_module.localsymtable);
  1920. { Win32 startup code needs a single name }
  1921. if not(target_info.system in (systems_darwin+systems_aix)) then
  1922. main_procinfo.procdef.aliasnames.insert('PASCALMAIN')
  1923. else
  1924. main_procinfo.procdef.aliasnames.insert(target_info.Cprefix+'PASCALMAIN')
  1925. end
  1926. else if (target_info.system in ([system_i386_netware,system_i386_netwlibc,system_powerpc_macos]+systems_darwin+systems_aix)) then
  1927. begin
  1928. { create a stub with the name of the desired main routine, with
  1929. the same signature as the C "main" function, and call through to
  1930. FPC_SYSTEMMAIN, which will initialise everything based on its
  1931. parameters. This function cannot be in the system unit, because
  1932. its name can be configured on the command line (for use with e.g.
  1933. SDL, where the main function should be called SDL_main) }
  1934. main_procinfo:=create_main_proc(mainaliasname,potype_mainstub,current_module.localsymtable);
  1935. call_through_new_name(main_procinfo.procdef,target_info.cprefix+'FPC_SYSTEMMAIN');
  1936. main_procinfo.free;
  1937. { now create the PASCALMAIN routine (which will be called from
  1938. FPC_SYSTEMMAIN) }
  1939. main_procinfo:=create_main_proc('PASCALMAIN',potype_proginit,current_module.localsymtable);
  1940. end
  1941. else
  1942. begin
  1943. main_procinfo:=create_main_proc(mainaliasname,potype_proginit,current_module.localsymtable);
  1944. main_procinfo.procdef.aliasnames.insert('PASCALMAIN');
  1945. end;
  1946. main_procinfo.parse_body;
  1947. { save file pos for debuginfo }
  1948. current_module.mainfilepos:=main_procinfo.entrypos;
  1949. { Generate specializations of objectdefs methods }
  1950. generate_specialization_procs;
  1951. { Generate VMTs }
  1952. if Errorcount=0 then
  1953. write_vmts(current_module.localsymtable,false);
  1954. { add implementations for synthetic method declarations added by
  1955. the compiler }
  1956. add_synthetic_method_implementations(current_module.localsymtable);
  1957. { should we force unit initialization? }
  1958. force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
  1959. if force_init_final or cnodeutils.force_init then
  1960. init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable);
  1961. { Add symbol to the exports section for win32 so smartlinking a
  1962. DLL will include the edata section }
  1963. if assigned(exportlib) and
  1964. (target_info.system in [system_i386_win32,system_i386_wdosx]) and
  1965. ((current_module.flags and uf_has_exports)<>0) then
  1966. current_asmdata.asmlists[al_procedures].concat(tai_const.createname(make_mangledname('EDATA',current_module.localsymtable,''),0));
  1967. { finalize? }
  1968. if token=_FINALIZATION then
  1969. begin
  1970. { Parse the finalize }
  1971. finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
  1972. finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
  1973. finalize_procinfo.procdef.aliasnames.insert('PASCALFINALIZE');
  1974. finalize_procinfo.parse_body;
  1975. end
  1976. else
  1977. if force_init_final or cnodeutils.force_final then
  1978. finalize_procinfo:=gen_implicit_initfinal(uf_finalize,current_module.localsymtable);
  1979. { the finalization routine of libraries is generic (and all libraries need to }
  1980. { be finalized, so they can finalize any units they use }
  1981. if (islibrary) then
  1982. exportlib.setfininame(current_asmdata.asmlists[al_procedures],'FPC_LIB_EXIT');
  1983. { all labels must be defined before generating code }
  1984. if Errorcount=0 then
  1985. tstoredsymtable(current_module.localsymtable).checklabels;
  1986. { See remark in unit init/final }
  1987. main_procinfo.generate_code;
  1988. main_procinfo.resetprocdef;
  1989. release_main_proc(main_procinfo);
  1990. if assigned(init_procinfo) then
  1991. begin
  1992. { initialization can be implicit only }
  1993. current_module.flags:=current_module.flags or uf_init;
  1994. init_procinfo.code:=cnodeutils.wrap_proc_body(init_procinfo.procdef,init_procinfo.code);
  1995. init_procinfo.generate_code;
  1996. init_procinfo.resetprocdef;
  1997. release_main_proc(init_procinfo);
  1998. end;
  1999. if assigned(finalize_procinfo) then
  2000. begin
  2001. if force_init_final or
  2002. cnodeutils.force_init or
  2003. not(has_no_code(finalize_procinfo.code)) then
  2004. begin
  2005. finalize_procinfo.code:=cnodeutils.wrap_proc_body(finalize_procinfo.procdef,finalize_procinfo.code);
  2006. finalize_procinfo.generate_code;
  2007. current_module.flags:=current_module.flags or uf_finalize;
  2008. end;
  2009. finalize_procinfo.resetprocdef;
  2010. release_main_proc(finalize_procinfo);
  2011. end;
  2012. symtablestack.pop(current_module.localsymtable);
  2013. { consume the last point }
  2014. consume(_POINT);
  2015. { reset wpo flags for all defs }
  2016. reset_all_defs;
  2017. if (Errorcount=0) then
  2018. begin
  2019. { test static symtable }
  2020. tstoredsymtable(current_module.localsymtable).allsymbolsused;
  2021. tstoredsymtable(current_module.localsymtable).allprivatesused;
  2022. tstoredsymtable(current_module.localsymtable).check_forwards;
  2023. current_module.allunitsused;
  2024. end;
  2025. { leave when we got an error }
  2026. if (Errorcount>0) and not status.skip_error then
  2027. begin
  2028. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  2029. status.skip_error:=true;
  2030. exit;
  2031. end;
  2032. { remove all unused units, this happens when units are removed
  2033. from the uses clause in the source and the ppu was already being loaded }
  2034. hp:=tmodule(loaded_units.first);
  2035. while assigned(hp) do
  2036. begin
  2037. hp2:=hp;
  2038. hp:=tmodule(hp.next);
  2039. if hp2.is_unit and
  2040. not assigned(hp2.globalsymtable) then
  2041. begin
  2042. loaded_units.remove(hp2);
  2043. unloaded_units.concat(hp2);
  2044. end;
  2045. end;
  2046. { do we need to add the variants unit? }
  2047. maybeloadvariantsunit;
  2048. { Now that everything has been compiled we know if we need resource
  2049. support. If not, remove the unit. }
  2050. resources_used:=MaybeRemoveResUnit;
  2051. linker.initsysinitunitname;
  2052. if target_info.system in systems_internal_sysinit then
  2053. begin
  2054. { add start/halt unit }
  2055. AddUnit(linker.sysinitunit);
  2056. end;
  2057. {$ifdef arm}
  2058. { Insert .pdata section for arm-wince.
  2059. It is needed for exception handling. }
  2060. if target_info.system in [system_arm_wince] then
  2061. InsertPData;
  2062. {$endif arm}
  2063. cnodeutils.InsertThreadvars;
  2064. { generate rtti/init tables }
  2065. write_persistent_type_info(current_module.localsymtable,false);
  2066. { if an Objective-C module, generate rtti and module info }
  2067. MaybeGenerateObjectiveCImageInfo(nil,current_module.localsymtable);
  2068. { generate imports }
  2069. if current_module.ImportLibraryList.Count>0 then
  2070. importlib.generatelib;
  2071. { generate debuginfo }
  2072. if (cs_debuginfo in current_settings.moduleswitches) then
  2073. current_debuginfo.inserttypeinfo;
  2074. if islibrary or (target_info.system in systems_unit_program_exports) then
  2075. exportlib.generatelib;
  2076. { Reference all DEBUGINFO sections from the main .fpc section }
  2077. if (cs_debuginfo in current_settings.moduleswitches) then
  2078. current_debuginfo.referencesections(current_asmdata.asmlists[al_procedures]);
  2079. { Resource strings }
  2080. GenerateResourceStrings;
  2081. { Windows widestring needing initialization }
  2082. cnodeutils.InsertWideInits;
  2083. { Resourcestring references (const foo:string=someresourcestring) }
  2084. cnodeutils.InsertResStrInits;
  2085. { insert Tables and StackLength }
  2086. cnodeutils.InsertInitFinalTable;
  2087. cnodeutils.InsertThreadvarTablesTable;
  2088. cnodeutils.InsertResourceTablesTable;
  2089. cnodeutils.InsertWideInitsTablesTable;
  2090. cnodeutils.InsertResStrTablesTable;
  2091. cnodeutils.InsertMemorySizes;
  2092. { Insert symbol to resource info }
  2093. cnodeutils.InsertResourceInfo(resources_used);
  2094. { create callframe info }
  2095. create_dwarf_frame;
  2096. { insert own objectfile }
  2097. insertobjectfile;
  2098. { assemble and link }
  2099. create_objectfile;
  2100. { We might need the symbols info if not using
  2101. the default do_extractsymbolinfo
  2102. which is a dummy function PM }
  2103. needsymbolinfo:=
  2104. (do_extractsymbolinfo<>@def_extractsymbolinfo) or
  2105. ((current_settings.genwpoptimizerswitches*WPOptimizationsNeedingAllUnitInfo)<>[]);
  2106. { release all local symtables that are not needed anymore }
  2107. if (not needsymbolinfo) then
  2108. free_localsymtables(current_module.localsymtable);
  2109. { leave when we got an error }
  2110. if (Errorcount>0) and not status.skip_error then
  2111. begin
  2112. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  2113. status.skip_error:=true;
  2114. exit;
  2115. end;
  2116. if (not current_module.is_unit) then
  2117. begin
  2118. { create the executable when we are at level 1 }
  2119. if (compile_level=1) then
  2120. begin
  2121. { create global resource file by collecting all resource files }
  2122. CollectResourceFiles;
  2123. { write .def file }
  2124. if (cs_link_deffile in current_settings.globalswitches) then
  2125. deffile.writefile;
  2126. { insert all .o files from all loaded units and
  2127. unload the units, we don't need them anymore.
  2128. Keep the current_module because that is still needed }
  2129. hp:=tmodule(loaded_units.first);
  2130. while assigned(hp) do
  2131. begin
  2132. linker.AddModuleFiles(hp);
  2133. hp2:=tmodule(hp.next);
  2134. if (hp<>current_module) and
  2135. (not needsymbolinfo) then
  2136. begin
  2137. loaded_units.remove(hp);
  2138. hp.free;
  2139. end;
  2140. hp:=hp2;
  2141. end;
  2142. { free also unneeded units we didn't free before }
  2143. if not needsymbolinfo then
  2144. unloaded_units.Clear;
  2145. { finally we can create a executable }
  2146. if DLLSource then
  2147. linker.MakeSharedLibrary
  2148. else
  2149. linker.MakeExecutable;
  2150. { collect all necessary information for whole-program optimization }
  2151. wpoinfomanager.extractwpoinfofromprogram;
  2152. end;
  2153. { Give Fatal with error count for linker errors }
  2154. if (Errorcount>0) and not status.skip_error then
  2155. begin
  2156. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  2157. status.skip_error:=true;
  2158. end;
  2159. end;
  2160. end;
  2161. end.