pmodules.pas 87 KB

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