pmodules.pas 84 KB

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