pmodules.pas 92 KB

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