pmodules.pas 61 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. Handles the parsing and loading of the modules (ppufiles)
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pmodules;
  19. {$i fpcdefs.inc}
  20. {$define New_GDB}
  21. interface
  22. procedure proc_unit;
  23. procedure proc_program(islibrary : boolean);
  24. implementation
  25. uses
  26. globtype,version,systems,tokens,
  27. cutils,cclasses,comphook,
  28. globals,verbose,fmodule,finput,fppu,
  29. symconst,symbase,symtype,symdef,symsym,symtable,
  30. aasmbase,aasmtai,aasmcpu,
  31. cgbase,cpuinfo,cgobj,
  32. nbas,ncgutil,
  33. link,assemble,import,export,gendef,ppu,comprsrc,
  34. cresstr,cpubase,
  35. {$ifdef GDB}
  36. gdb,
  37. {$endif GDB}
  38. scanner,pbase,pexpr,psystem,psub;
  39. procedure fixseg(p:TAAsmoutput;sec:TSection);
  40. begin
  41. p.insert(Tai_section.Create(sec));
  42. if (cs_create_smart in aktmoduleswitches) then
  43. p.insert(Tai_cut.Create);
  44. p.concat(Tai_section.Create(sec_none));
  45. end;
  46. procedure create_objectfile;
  47. var
  48. DLLScanner : TDLLScanner;
  49. s : string;
  50. KeepShared : TStringList;
  51. begin
  52. { try to create import entries from system dlls }
  53. if target_info.DllScanSupported and
  54. (not current_module.linkOtherSharedLibs.Empty) then
  55. begin
  56. { Init DLLScanner }
  57. if assigned(CDLLScanner[target_info.system]) then
  58. DLLScanner:=CDLLScanner[target_info.system].Create
  59. else
  60. internalerror(200104121);
  61. KeepShared:=TStringList.Create;
  62. { Walk all shared libs }
  63. While not current_module.linkOtherSharedLibs.Empty do
  64. begin
  65. S:=current_module.linkOtherSharedLibs.Getusemask(link_allways);
  66. if not DLLScanner.scan(s) then
  67. KeepShared.Concat(s);
  68. end;
  69. DLLscanner.Free;
  70. { Recreate import section }
  71. if (target_info.system in [system_i386_win32,system_i386_wdosx]) then
  72. begin
  73. if assigned(importssection)then
  74. importssection.clear
  75. else
  76. importssection:=taasmoutput.Create;
  77. importlib.generatelib;
  78. end;
  79. { Readd the not processed files }
  80. while not KeepShared.Empty do
  81. begin
  82. s:=KeepShared.GetFirst;
  83. current_module.linkOtherSharedLibs.add(s,link_allways);
  84. end;
  85. KeepShared.Free;
  86. end;
  87. { create the .s file and assemble it }
  88. GenerateAsm(false);
  89. { Also create a smartlinked version ? }
  90. if (cs_create_smart in aktmoduleswitches) then
  91. begin
  92. { regenerate the importssection for win32 }
  93. if assigned(importssection) and
  94. (target_info.system in [system_i386_win32,system_i386_wdosx]) then
  95. begin
  96. importsSection.clear;
  97. importlib.generatesmartlib;
  98. end;
  99. GenerateAsm(true);
  100. if target_asm.needar then
  101. Linker.MakeStaticLibrary;
  102. end;
  103. { resource files }
  104. CompileResourceFiles;
  105. end;
  106. procedure insertobjectfile;
  107. { Insert the used object file for this unit in the used list for this unit }
  108. begin
  109. current_module.linkunitofiles.add(current_module.objfilename^,link_static);
  110. current_module.flags:=current_module.flags or uf_static_linked;
  111. if (cs_create_smart in aktmoduleswitches) then
  112. begin
  113. current_module.linkunitstaticlibs.add(current_module.staticlibfilename^,link_smart);
  114. current_module.flags:=current_module.flags or uf_smart_linked;
  115. end;
  116. end;
  117. procedure insertsegment;
  118. begin
  119. { Insert Ident of the compiler }
  120. if (not (cs_create_smart in aktmoduleswitches))
  121. {$ifndef EXTDEBUG}
  122. and (not current_module.is_unit)
  123. {$endif}
  124. then
  125. begin
  126. { align the first data }
  127. dataSegment.insert(Tai_align.Create(const_align(32)));
  128. dataSegment.insert(Tai_string.Create('FPC '+full_version_string+
  129. ' ['+date_string+'] for '+target_cpu_string+' - '+target_info.shortname));
  130. end;
  131. { align code segment }
  132. codeSegment.concat(Tai_align.Create(aktalignment.procalign));
  133. { Insert start and end of sections }
  134. fixseg(codesegment,sec_code);
  135. fixseg(datasegment,sec_data);
  136. fixseg(bsssegment,sec_bss);
  137. { we should use .rdata section for these two no ? }
  138. { .rdata is a read only data section (PM) }
  139. fixseg(rttilist,sec_data);
  140. fixseg(consts,sec_data);
  141. if assigned(resourcestringlist) then
  142. fixseg(resourcestringlist,sec_data);
  143. {$ifdef GDB}
  144. if assigned(debuglist) then
  145. begin
  146. debugList.insert(Tai_symbol.Createname('gcc2_compiled',0));
  147. debugList.insert(Tai_symbol.Createname('fpc_compiled',0));
  148. fixseg(debuglist,sec_code);
  149. end;
  150. {$endif GDB}
  151. end;
  152. procedure InsertThreadvarTablesTable;
  153. var
  154. hp : tused_unit;
  155. ltvTables : taasmoutput;
  156. count : longint;
  157. begin
  158. ltvTables:=TAAsmOutput.Create;
  159. count:=0;
  160. hp:=tused_unit(usedunits.first);
  161. while assigned(hp) do
  162. begin
  163. If (hp.u.flags and uf_threadvars)=uf_threadvars then
  164. begin
  165. ltvTables.concat(Tai_const_symbol.Createdataname(hp.u.modulename^+'_$THREADVARLIST'));
  166. inc(count);
  167. end;
  168. hp:=tused_unit(hp.next);
  169. end;
  170. { Add program threadvars, if any }
  171. If (current_module.flags and uf_threadvars)=uf_threadvars then
  172. begin
  173. ltvTables.concat(Tai_const_symbol.Createdataname(current_module.modulename^+'_$THREADVARLIST'));
  174. inc(count);
  175. end;
  176. { TableCount }
  177. ltvTables.insert(Tai_const.Create_32bit(count));
  178. ltvTables.insert(Tai_symbol.Createdataname_global('FPC_THREADVARTABLES',0));
  179. ltvTables.insert(Tai_align.Create(const_align(pointer_size)));
  180. ltvTables.concat(Tai_symbol_end.Createname('FPC_THREADVARTABLES'));
  181. { insert in data segment }
  182. if (cs_create_smart in aktmoduleswitches) then
  183. dataSegment.concat(Tai_cut.Create);
  184. dataSegment.concatlist(ltvTables);
  185. ltvTables.free;
  186. end;
  187. procedure AddToThreadvarList(p:tnamedindexitem;arg:pointer);
  188. var
  189. ltvTable : taasmoutput;
  190. begin
  191. ltvTable:=taasmoutput(arg);
  192. if (tsym(p).typ=varsym) and
  193. (vo_is_thread_var in tvarsym(p).varoptions) then
  194. begin
  195. { address of threadvar }
  196. ltvTable.concat(tai_const_symbol.createdataname(tvarsym(p).mangledname));
  197. { size of threadvar }
  198. ltvTable.concat(tai_const.create_32bit(tvarsym(p).getsize));
  199. end;
  200. end;
  201. procedure InsertThreadvars;
  202. var
  203. ltvTable : TAAsmoutput;
  204. begin
  205. ltvTable:=TAAsmoutput.create;
  206. if assigned(current_module.globalsymtable) then
  207. current_module.globalsymtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}AddToThreadvarList,ltvTable);
  208. current_module.localsymtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}AddToThreadvarList,ltvTable);
  209. if ltvTable.first<>nil then
  210. begin
  211. { add begin and end of the list }
  212. ltvTable.insert(tai_symbol.createdataname_global(current_module.modulename^+'_$THREADVARLIST',0));
  213. ltvTable.concat(tai_const.create_32bit(0)); { end of list marker }
  214. ltvTable.concat(tai_symbol_end.createname(current_module.modulename^+'_$THREADVARLIST'));
  215. if (cs_create_smart in aktmoduleswitches) then
  216. dataSegment.concat(Tai_cut.Create);
  217. dataSegment.concatlist(ltvTable);
  218. current_module.flags:=current_module.flags or uf_threadvars;
  219. end;
  220. ltvTable.Free;
  221. end;
  222. Procedure InsertResourceTablesTable;
  223. var
  224. hp : tused_unit;
  225. ResourceStringTables : taasmoutput;
  226. count : longint;
  227. begin
  228. ResourceStringTables:=TAAsmOutput.Create;
  229. count:=0;
  230. hp:=tused_unit(usedunits.first);
  231. while assigned(hp) do
  232. begin
  233. If (hp.u.flags and uf_has_resources)=uf_has_resources then
  234. begin
  235. ResourceStringTables.concat(Tai_const_symbol.Createdataname(hp.u.modulename^+'_RESOURCESTRINGLIST'));
  236. inc(count);
  237. end;
  238. hp:=tused_unit(hp.next);
  239. end;
  240. { Add program resources, if any }
  241. If ResourceStringList<>Nil then
  242. begin
  243. ResourceStringTables.concat(Tai_const_symbol.Createdataname(current_module.modulename^+'_RESOURCESTRINGLIST'));
  244. Inc(Count);
  245. end;
  246. { TableCount }
  247. ResourceStringTables.insert(Tai_const.Create_32bit(count));
  248. ResourceStringTables.insert(Tai_symbol.Createdataname_global('FPC_RESOURCESTRINGTABLES',0));
  249. ResourceStringTables.insert(Tai_align.Create(const_align(4)));
  250. ResourceStringTables.concat(Tai_symbol_end.Createname('FPC_RESOURCESTRINGTABLES'));
  251. { insert in data segment }
  252. if (cs_create_smart in aktmoduleswitches) then
  253. dataSegment.concat(Tai_cut.Create);
  254. dataSegment.concatlist(ResourceStringTables);
  255. ResourceStringTables.free;
  256. end;
  257. procedure InsertInitFinalTable;
  258. var
  259. hp : tused_unit;
  260. unitinits : taasmoutput;
  261. count : longint;
  262. begin
  263. unitinits:=TAAsmOutput.Create;
  264. count:=0;
  265. hp:=tused_unit(usedunits.first);
  266. while assigned(hp) do
  267. begin
  268. { call the unit init code and make it external }
  269. if (hp.u.flags and (uf_init or uf_finalize))<>0 then
  270. begin
  271. if (hp.u.flags and uf_init)<>0 then
  272. unitinits.concat(Tai_const_symbol.Createname('INIT$$'+hp.u.modulename^))
  273. else
  274. unitinits.concat(Tai_const.Create_32bit(0));
  275. if (hp.u.flags and uf_finalize)<>0 then
  276. unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+hp.u.modulename^))
  277. else
  278. unitinits.concat(Tai_const.Create_32bit(0));
  279. inc(count);
  280. end;
  281. hp:=tused_unit(hp.next);
  282. end;
  283. { Insert initialization/finalization of the program }
  284. if (current_module.flags and (uf_init or uf_finalize))<>0 then
  285. begin
  286. if (current_module.flags and uf_init)<>0 then
  287. unitinits.concat(Tai_const_symbol.Createname('INIT$$'+current_module.modulename^))
  288. else
  289. unitinits.concat(Tai_const.Create_32bit(0));
  290. if (current_module.flags and uf_finalize)<>0 then
  291. unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+current_module.modulename^))
  292. else
  293. unitinits.concat(Tai_const.Create_32bit(0));
  294. inc(count);
  295. end;
  296. { TableCount,InitCount }
  297. unitinits.insert(Tai_const.Create_32bit(0));
  298. unitinits.insert(Tai_const.Create_32bit(count));
  299. unitinits.insert(Tai_symbol.Createdataname_global('INITFINAL',0));
  300. unitinits.insert(Tai_align.Create(const_align(4)));
  301. unitinits.concat(Tai_symbol_end.Createname('INITFINAL'));
  302. { insert in data segment }
  303. if (cs_create_smart in aktmoduleswitches) then
  304. dataSegment.concat(Tai_cut.Create);
  305. dataSegment.concatlist(unitinits);
  306. unitinits.free;
  307. end;
  308. procedure insertheap;
  309. begin
  310. if (cs_create_smart in aktmoduleswitches) then
  311. begin
  312. bssSegment.concat(Tai_cut.Create);
  313. dataSegment.concat(Tai_cut.Create);
  314. end;
  315. { On the Macintosh Classic M68k Architecture
  316. The Heap variable is simply a POINTER to the
  317. real HEAP. The HEAP must be set up by the RTL
  318. and must store the pointer in this value.
  319. On OS/2 the heap is also intialized by the RTL. We do
  320. not output a pointer }
  321. case target_info.system of
  322. system_i386_OS2,system_i386_EMX:
  323. ;
  324. system_powerpc_macos:
  325. ;
  326. system_alpha_linux:
  327. ;
  328. system_m68k_Mac:
  329. bssSegment.concat(Tai_datablock.Create_global('HEAP',4));
  330. system_m68k_PalmOS:
  331. ;
  332. else
  333. begin
  334. bssSegment.concat(Tai_align.Create(var_align(heapsize)));
  335. bssSegment.concat(Tai_datablock.Create_global('HEAP',heapsize));
  336. end;
  337. end;
  338. {$ifdef m68k}
  339. if target_info.system<>system_m68k_PalmOS then
  340. begin
  341. dataSegment.concat(Tai_align.Create(const_align(4)));
  342. dataSegment.concat(Tai_symbol.Createdataname_global('HEAPSIZE',4));
  343. dataSegment.concat(Tai_const.Create_32bit(heapsize));
  344. end;
  345. {$else m68k}
  346. dataSegment.concat(Tai_align.Create(const_align(4)));
  347. dataSegment.concat(Tai_symbol.Createdataname_global('HEAPSIZE',4));
  348. dataSegment.concat(Tai_const.Create_32bit(heapsize));
  349. {$endif m68k}
  350. end;
  351. procedure insertstacklength;
  352. begin
  353. { stacksize can be specified and is now simulated }
  354. dataSegment.concat(Tai_align.Create(const_align(4)));
  355. dataSegment.concat(Tai_symbol.Createdataname_global('__stklen',4));
  356. dataSegment.concat(Tai_const.Create_32bit(stacksize));
  357. end;
  358. procedure loaddefaultunits;
  359. procedure AddUnit(const s:string);
  360. var
  361. hp : tppumodule;
  362. unitsym : tunitsym;
  363. begin
  364. { load unit }
  365. hp:=registerunit(current_module,s,'');
  366. hp.loadppu;
  367. hp.adddependency(current_module);
  368. current_module.addusedunit(hp,false);
  369. { add to symtable stack }
  370. tsymtable(hp.globalsymtable).next:=symtablestack;
  371. symtablestack:=hp.globalsymtable;
  372. { insert unitsym }
  373. unitsym:=tunitsym.create(s,hp.globalsymtable);
  374. inc(unitsym.refs);
  375. refsymtable.insert(unitsym);
  376. end;
  377. begin
  378. { are we compiling the system unit? }
  379. if (cs_compilesystem in aktmoduleswitches) then
  380. begin
  381. { create system defines }
  382. createconstdefs;
  383. { we don't need to reset anything, it's already done in parser.pas }
  384. exit;
  385. end;
  386. { insert the system unit, it is allways the first }
  387. Symtablestack:=nil;
  388. AddUnit('System');
  389. SystemUnit:=TGlobalSymtable(Symtablestack);
  390. { read default constant definitions }
  391. make_ref:=false;
  392. readconstdefs;
  393. make_ref:=true;
  394. {$ifdef cpufpemu}
  395. { Floating point emulation unit? }
  396. if (cs_fp_emulation in aktmoduleswitches) then
  397. AddUnit('SoftFpu');
  398. {$endif cpufpemu}
  399. { Thread support unit? }
  400. if (cs_threading in aktmoduleswitches) then
  401. AddUnit('SysThrds');
  402. { Objpas unit? }
  403. if m_objpas in aktmodeswitches then
  404. AddUnit('ObjPas');
  405. { Profile unit? Needed for go32v2 only }
  406. if (cs_profile in aktmoduleswitches) and
  407. (target_info.system in [system_i386_go32v2,system_i386_watcom]) then
  408. AddUnit('Profile');
  409. { Units only required for main module }
  410. if not(current_module.is_unit) then
  411. begin
  412. { Heaptrc unit }
  413. if (cs_gdb_heaptrc in aktglobalswitches) then
  414. AddUnit('HeapTrc');
  415. { Lineinfo unit }
  416. if (cs_gdb_lineinfo in aktglobalswitches) then
  417. AddUnit('LineInfo');
  418. end;
  419. { save default symtablestack }
  420. defaultsymtablestack:=symtablestack;
  421. end;
  422. procedure loadunits;
  423. var
  424. s,sorg : stringid;
  425. fn : string;
  426. pu : tused_unit;
  427. hp2 : tmodule;
  428. hp3 : tsymtable;
  429. unitsym : tunitsym;
  430. begin
  431. consume(_USES);
  432. {$ifdef DEBUG}
  433. test_symtablestack;
  434. {$endif DEBUG}
  435. repeat
  436. s:=pattern;
  437. sorg:=orgpattern;
  438. consume(_ID);
  439. { support "<unit> in '<file>'" construct, but not for tp7 }
  440. if not(m_tp7 in aktmodeswitches) then
  441. begin
  442. if try_to_consume(_OP_IN) then
  443. fn:=FixFileName(get_stringconst)
  444. else
  445. fn:='';
  446. end;
  447. { Give a warning if objpas is loaded }
  448. if s='OBJPAS' then
  449. Message(parser_w_no_objpas_use_mode);
  450. { Using the unit itself is not possible }
  451. if (s<>current_module.modulename^) then
  452. begin
  453. { check if the unit is already used }
  454. hp2:=nil;
  455. pu:=tused_unit(current_module.used_units.first);
  456. while assigned(pu) do
  457. begin
  458. if (pu.u.modulename^=s) then
  459. begin
  460. hp2:=pu.u;
  461. break;
  462. end;
  463. pu:=tused_unit(pu.next);
  464. end;
  465. { Need to register the unit? }
  466. if not assigned(hp2) then
  467. hp2:=registerunit(current_module,sorg,fn);
  468. { the current module uses the unit hp2 }
  469. current_module.addusedunit(hp2,true);
  470. end
  471. else
  472. Message1(sym_e_duplicate_id,s);
  473. if token=_COMMA then
  474. begin
  475. pattern:='';
  476. consume(_COMMA);
  477. end
  478. else
  479. break;
  480. until false;
  481. consume(_SEMICOLON);
  482. { Load the units }
  483. pu:=tused_unit(current_module.used_units.first);
  484. while assigned(pu) do
  485. begin
  486. if pu.in_uses then
  487. begin
  488. { store the original name to create the unitsym }
  489. sorg:=pu.u.realmodulename^;
  490. tppumodule(pu.u).loadppu;
  491. { is our module compiled? then we can stop }
  492. if current_module.state=ms_compiled then
  493. exit;
  494. { add this unit to the dependencies }
  495. pu.u.adddependency(current_module);
  496. pu.checksum:=pu.u.crc;
  497. pu.interface_checksum:=pu.u.interface_crc;
  498. { Create unitsym, we need to use the name as specified, we
  499. can not use the modulename because that can be different
  500. when -Un is used. But when the names are the same then
  501. force the name of the module so there will be no difference
  502. in the case of the name }
  503. if upper(sorg)=pu.u.modulename^ then
  504. sorg:=pu.u.realmodulename^;
  505. unitsym:=tunitsym.create(sorg,pu.u.globalsymtable);
  506. if (pu.u.flags and (uf_init or uf_finalize))<>0 then
  507. inc(unitsym.refs);
  508. refsymtable.insert(unitsym);
  509. end;
  510. pu:=tused_unit(pu.next);
  511. end;
  512. { set the symtable to systemunit so it gets reorderd correctly,
  513. then insert the units in the symtablestack }
  514. pu:=tused_unit(current_module.used_units.first);
  515. symtablestack:=defaultsymtablestack;
  516. while assigned(pu) do
  517. begin
  518. {$IfDef GDB}
  519. if (cs_debuginfo in aktmoduleswitches) and
  520. (cs_gdb_dbx in aktglobalswitches) and
  521. not pu.is_stab_written then
  522. begin
  523. tglobalsymtable(pu.u.globalsymtable).concattypestabto(debuglist);
  524. pu.is_stab_written:=true;
  525. pu.unitid:=tsymtable(pu.u.globalsymtable).unitid;
  526. end;
  527. {$EndIf GDB}
  528. if pu.in_uses then
  529. begin
  530. { Reinsert in symtablestack }
  531. hp3:=symtablestack;
  532. while assigned(hp3) do
  533. begin
  534. { insert units only once ! }
  535. if pu.u.globalsymtable=hp3 then
  536. break;
  537. hp3:=hp3.next;
  538. { unit isn't inserted }
  539. if hp3=nil then
  540. begin
  541. tsymtable(pu.u.globalsymtable).next:=symtablestack;
  542. symtablestack:=tsymtable(pu.u.globalsymtable);
  543. {$ifdef DEBUG}
  544. test_symtablestack;
  545. {$endif DEBUG}
  546. end;
  547. end;
  548. end;
  549. pu:=tused_unit(pu.next);
  550. end;
  551. end;
  552. procedure write_gdb_info;
  553. {$IfDef GDB}
  554. var
  555. hp : tused_unit;
  556. begin
  557. if not (cs_debuginfo in aktmoduleswitches) then
  558. exit;
  559. { now insert the units in the symtablestack }
  560. hp:=tused_unit(current_module.used_units.first);
  561. while assigned(hp) do
  562. begin
  563. if (cs_debuginfo in aktmoduleswitches) and
  564. not hp.is_stab_written then
  565. begin
  566. tglobalsymtable(hp.u.globalsymtable).concattypestabto(debuglist);
  567. hp.is_stab_written:=true;
  568. hp.unitid:=tsymtable(hp.u.globalsymtable).unitid;
  569. end;
  570. hp:=tused_unit(hp.next);
  571. end;
  572. if (not current_module.in_interface) and
  573. assigned(current_module.localsymtable) then
  574. begin
  575. { all types }
  576. tstaticsymtable(current_module.localsymtable).concattypestabto(debuglist);
  577. { and all local symbols}
  578. tstaticsymtable(current_module.localsymtable).concatstabto(debuglist);
  579. end
  580. else if assigned(current_module.globalsymtable) then
  581. begin
  582. { all types }
  583. tglobalsymtable(current_module.globalsymtable).concattypestabto(debuglist);
  584. { and all local symbols}
  585. tglobalsymtable(current_module.globalsymtable).concatstabto(debuglist);
  586. end;
  587. if (cs_gdb_dbx in aktglobalswitches) then
  588. begin
  589. debugList.concat(tai_comment.Create(strpnew('EINCL of global '+
  590. tglobalsymtable(current_module.globalsymtable).name^+' has index '+
  591. tostr(tglobalsymtable(current_module.globalsymtable).unitid))));
  592. debugList.concat(Tai_stabs.Create(strpnew('"'+
  593. tglobalsymtable(current_module.globalsymtable).name^+'",'+
  594. tostr(N_EINCL)+',0,0,0')));
  595. tglobalsymtable(current_module.globalsymtable).dbx_count_ok:={true}false;
  596. dbx_counter:=tglobalsymtable(current_module.globalsymtable).prev_dbx_counter;
  597. do_count_dbx:=false;
  598. end;
  599. end;
  600. {$Else GDB}
  601. begin
  602. end;
  603. {$EndIf GDB}
  604. procedure parse_implementation_uses(symt:tsymtable);
  605. begin
  606. if token=_USES then
  607. begin
  608. loadunits;
  609. {$ifdef DEBUG}
  610. test_symtablestack;
  611. {$endif DEBUG}
  612. end;
  613. end;
  614. procedure setupglobalswitches;
  615. begin
  616. { can't have local browser when no global browser }
  617. if (cs_local_browser in aktmoduleswitches) and
  618. not(cs_browser in aktmoduleswitches) then
  619. exclude(aktmoduleswitches,cs_local_browser);
  620. { define a symbol in delphi,objfpc,tp,gpc mode }
  621. if (m_delphi in aktmodeswitches) then
  622. current_scanner.def_macro('FPC_DELPHI')
  623. else
  624. if (m_tp7 in aktmodeswitches) then
  625. current_scanner.def_macro('FPC_TP')
  626. else
  627. if (m_objfpc in aktmodeswitches) then
  628. current_scanner.def_macro('FPC_OBJFPC')
  629. else
  630. if (m_gpc in aktmodeswitches) then
  631. current_scanner.def_macro('FPC_GPC');
  632. end;
  633. function create_main_proc(const name:string;potype:tproctypeoption;st:tsymtable):tprocdef;
  634. var
  635. stt : tsymtable;
  636. ps : tprocsym;
  637. pd : tprocdef;
  638. begin
  639. { there should be no current_procinfo available }
  640. if assigned(current_procinfo) then
  641. internalerror(200304275);
  642. {Generate a procsym for main}
  643. make_ref:=false;
  644. { try to insert in in static symtable ! }
  645. stt:=symtablestack;
  646. symtablestack:=st;
  647. { generate procsym }
  648. ps:=tprocsym.create('$'+name);
  649. { main are allways used }
  650. inc(ps.refs);
  651. symtablestack.insert(ps);
  652. pd:=tprocdef.create(main_program_level);
  653. include(pd.procoptions,po_public);
  654. pd.procsym:=ps;
  655. ps.addprocdef(pd);
  656. { restore symtable }
  657. make_ref:=true;
  658. symtablestack:=stt;
  659. { set procdef options }
  660. pd.proctypeoption:=potype;
  661. pd.proccalloption:=pocall_default;
  662. pd.forwarddef:=false;
  663. pd.setmangledname(target_info.cprefix+name);
  664. pd.aliasnames.insert(pd.mangledname);
  665. { We don't need is a local symtable. Change it into the static
  666. symtable }
  667. pd.localst.free;
  668. pd.localst:=st;
  669. { set procinfo and current_procinfo.procdef }
  670. current_procinfo:=cprocinfo.create(nil);
  671. current_module.procinfo:=current_procinfo;
  672. current_procinfo.procdef:=pd;
  673. { return procdef }
  674. create_main_proc:=pd;
  675. end;
  676. procedure release_main_proc(pd:tprocdef);
  677. begin
  678. { this is a main proc, so there should be no parent }
  679. if not(assigned(current_procinfo)) or
  680. assigned(current_procinfo.parent) or
  681. not(current_procinfo.procdef=pd) then
  682. internalerror(200304276);
  683. { remove procinfo }
  684. current_module.procinfo:=nil;
  685. current_procinfo.free;
  686. current_procinfo:=nil;
  687. { remove localst as it was replaced by staticsymtable }
  688. pd.localst:=nil;
  689. end;
  690. procedure gen_implicit_initfinal(list:taasmoutput;flag:word;st:tsymtable);
  691. var
  692. pd : tprocdef;
  693. begin
  694. { update module flags }
  695. current_module.flags:=current_module.flags or flag;
  696. { create procdef }
  697. case flag of
  698. uf_init :
  699. begin
  700. pd:=create_main_proc(current_module.modulename^+'_init_implicit',potype_unitinit,st);
  701. pd.aliasnames.insert('INIT$$'+current_module.modulename^);
  702. end;
  703. uf_finalize :
  704. begin
  705. pd:=create_main_proc(current_module.modulename^+'_finalize_implicit',potype_unitfinalize,st);
  706. pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
  707. end;
  708. else
  709. internalerror(200304253);
  710. end;
  711. tcgprocinfo(current_procinfo).code:=cnothingnode.create;
  712. add_entry_exit_code(tcgprocinfo(current_procinfo).code,aktfilepos,aktfilepos);
  713. tcgprocinfo(current_procinfo).generate_code;
  714. release_main_proc(pd);
  715. end;
  716. procedure proc_unit;
  717. function is_assembler_generated:boolean;
  718. begin
  719. is_assembler_generated:=(Errorcount=0) and
  720. not(
  721. codeSegment.empty and
  722. dataSegment.empty and
  723. bssSegment.empty and
  724. ((importssection=nil) or importsSection.empty) and
  725. ((resourcesection=nil) or resourceSection.empty) and
  726. ((resourcestringlist=nil) or resourcestringList.empty)
  727. );
  728. end;
  729. var
  730. main_file: tinputfile;
  731. st : tsymtable;
  732. unitst : tglobalsymtable;
  733. {$ifdef GDB}
  734. pu : tused_unit;
  735. {$endif GDB}
  736. store_crc,store_interface_crc : cardinal;
  737. s2 : ^string; {Saves stack space}
  738. force_init_final : boolean;
  739. initfinalcode : taasmoutput;
  740. pd : tprocdef;
  741. begin
  742. initfinalcode:=taasmoutput.create;
  743. consume(_UNIT);
  744. if compile_level=1 then
  745. Status.IsExe:=false;
  746. if token=_ID then
  747. begin
  748. { create filenames and unit name }
  749. main_file := current_scanner.inputfile;
  750. while assigned(main_file.next) do
  751. main_file := main_file.next;
  752. current_module.SetFileName(main_file.path^+main_file.name^,true);
  753. current_module.SetModuleName(orgpattern);
  754. { check for system unit }
  755. new(s2);
  756. s2^:=upper(SplitName(main_file.name^));
  757. if (cs_check_unit_name in aktglobalswitches) and
  758. not((current_module.modulename^=s2^) or
  759. ((length(current_module.modulename^)>8) and
  760. (copy(current_module.modulename^,1,8)=s2^))) then
  761. Message1(unit_e_illegal_unit_name,current_module.realmodulename^);
  762. if (current_module.modulename^='SYSTEM') then
  763. include(aktmoduleswitches,cs_compilesystem);
  764. dispose(s2);
  765. end;
  766. consume(_ID);
  767. consume(_SEMICOLON);
  768. consume(_INTERFACE);
  769. { global switches are read, so further changes aren't allowed }
  770. current_module.in_global:=false;
  771. { handle the global switches }
  772. setupglobalswitches;
  773. message1(unit_u_loading_interface_units,current_module.modulename^);
  774. { update status }
  775. status.currentmodule:=current_module.realmodulename^;
  776. { maybe turn off m_objpas if we are compiling objpas }
  777. if (current_module.modulename^='OBJPAS') then
  778. exclude(aktmodeswitches,m_objpas);
  779. parse_only:=true;
  780. { generate now the global symboltable }
  781. st:=tglobalsymtable.create(current_module.modulename^);
  782. refsymtable:=st;
  783. unitst:=tglobalsymtable(st);
  784. { define first as local to overcome dependency conflicts }
  785. current_module.localsymtable:=st;
  786. { the unit name must be usable as a unit specifier }
  787. { inside the unit itself (PM) }
  788. { this also forbids to have another symbol }
  789. { with the same name as the unit }
  790. refsymtable.insert(tunitsym.create(current_module.realmodulename^,unitst));
  791. { load default units, like the system unit }
  792. loaddefaultunits;
  793. { reset }
  794. make_ref:=true;
  795. { insert qualifier for the system unit (allows system.writeln) }
  796. if not(cs_compilesystem in aktmoduleswitches) then
  797. begin
  798. if token=_USES then
  799. begin
  800. loadunits;
  801. { has it been compiled at a higher level ?}
  802. if current_module.state=ms_compiled then
  803. begin
  804. { this unit symtable is obsolete }
  805. { dispose(unitst,done);
  806. disposed as localsymtable !! }
  807. RestoreUnitSyms;
  808. exit;
  809. end;
  810. end;
  811. { ... but insert the symbol table later }
  812. st.next:=symtablestack;
  813. symtablestack:=st;
  814. end
  815. else
  816. { while compiling a system unit, some types are directly inserted }
  817. begin
  818. st.next:=symtablestack;
  819. symtablestack:=st;
  820. insert_intern_types(st);
  821. end;
  822. { now we know the place to insert the constants }
  823. constsymtable:=symtablestack;
  824. { move the global symtab from the temporary local to global }
  825. current_module.globalsymtable:=current_module.localsymtable;
  826. current_module.localsymtable:=nil;
  827. reset_global_defs;
  828. { number all units, so we know if a unit is used by this unit or
  829. needs to be added implicitly }
  830. current_module.numberunits;
  831. { ... parse the declarations }
  832. Message1(parser_u_parsing_interface,current_module.realmodulename^);
  833. read_interface_declarations;
  834. { leave when we got an error }
  835. if (Errorcount>0) and not status.skip_error then
  836. begin
  837. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  838. status.skip_error:=true;
  839. exit;
  840. end;
  841. {$ifdef New_GDB}
  842. write_gdb_info;
  843. {$endIf Def New_GDB}
  844. if not(cs_compilesystem in aktmoduleswitches) and
  845. (Errorcount=0) then
  846. tppumodule(current_module).getppucrc;
  847. { we have a new interface loaded, reload all flagged units }
  848. reload_flagged_units;
  849. { Parse the implementation section }
  850. consume(_IMPLEMENTATION);
  851. current_module.in_interface:=false;
  852. current_module.interface_compiled:=true;
  853. Message1(unit_u_loading_implementation_units,current_module.modulename^);
  854. parse_only:=false;
  855. { generates static symbol table }
  856. st:=tstaticsymtable.create(current_module.modulename^);
  857. current_module.localsymtable:=st;
  858. { remove the globalsymtable from the symtable stack }
  859. { to reinsert it after loading the implementation units }
  860. symtablestack:=unitst.next;
  861. { we don't want implementation units symbols in unitsymtable !! PM }
  862. refsymtable:=st;
  863. { Read the implementation units }
  864. parse_implementation_uses(unitst);
  865. if current_module.state=ms_compiled then
  866. begin
  867. RestoreUnitSyms;
  868. exit;
  869. end;
  870. { reset ranges/stabs in exported definitions }
  871. reset_global_defs;
  872. { All units are read, now give them a number }
  873. current_module.numberunits;
  874. { now we can change refsymtable }
  875. refsymtable:=st;
  876. { but reinsert the global symtable as lasts }
  877. unitst.next:=symtablestack;
  878. symtablestack:=unitst;
  879. tstoredsymtable(symtablestack).chainoperators;
  880. {$ifdef DEBUG}
  881. test_symtablestack;
  882. {$endif DEBUG}
  883. constsymtable:=symtablestack;
  884. {$ifdef Splitheap}
  885. if testsplit then
  886. begin
  887. Split_Heap;
  888. allow_special:=true;
  889. Switch_to_temp_heap;
  890. end;
  891. { it will report all crossings }
  892. allow_special:=false;
  893. {$endif Splitheap}
  894. Message1(parser_u_parsing_implementation,current_module.modulename^);
  895. if current_module.in_interface then
  896. internalerror(200212285);
  897. { Compile the unit }
  898. pd:=create_main_proc(current_module.modulename^+'_init',potype_unitinit,st);
  899. pd.aliasnames.insert('INIT$$'+current_module.modulename^);
  900. tcgprocinfo(current_procinfo).parse_body;
  901. tcgprocinfo(current_procinfo).generate_code;
  902. tcgprocinfo(current_procinfo).resetprocdef;
  903. release_main_proc(pd);
  904. { if the unit contains ansi/widestrings, initialization and
  905. finalization code must be forced }
  906. force_init_final:=tglobalsymtable(current_module.globalsymtable).needs_init_final or
  907. tstaticsymtable(current_module.localsymtable).needs_init_final;
  908. { should we force unit initialization? }
  909. { this is a hack, but how can it be done better ? }
  910. if force_init_final and ((current_module.flags and uf_init)=0) then
  911. begin
  912. gen_implicit_initfinal(initfinalcode,uf_init,st);
  913. codesegment.concatlist(initfinalcode);
  914. end;
  915. { finalize? }
  916. if token=_FINALIZATION then
  917. begin
  918. { set module options }
  919. current_module.flags:=current_module.flags or uf_finalize;
  920. { Compile the finalize }
  921. pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st);
  922. pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
  923. tcgprocinfo(current_procinfo).parse_body;
  924. tcgprocinfo(current_procinfo).generate_code;
  925. tcgprocinfo(current_procinfo).resetprocdef;
  926. release_main_proc(pd);
  927. end
  928. else if force_init_final then
  929. begin
  930. gen_implicit_initfinal(initfinalcode,uf_finalize,st);
  931. codesegment.concatlist(initfinalcode);
  932. end;
  933. { the last char should always be a point }
  934. consume(_POINT);
  935. { generate a list of threadvars }
  936. InsertThreadvars;
  937. { Generate resoucestrings }
  938. If ResourceStrings.ResStrCount>0 then
  939. begin
  940. ResourceStrings.CreateResourceStringList;
  941. current_module.flags:=current_module.flags or uf_has_resources;
  942. { only write if no errors found }
  943. if (Errorcount=0) then
  944. ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
  945. end;
  946. { test static symtable }
  947. if (Errorcount=0) then
  948. begin
  949. tstoredsymtable(st).allsymbolsused;
  950. tstoredsymtable(st).allunitsused;
  951. tstoredsymtable(st).allprivatesused;
  952. end;
  953. { size of the static data }
  954. // datasize:=st.datasize;
  955. {$ifdef GDB}
  956. { add all used definitions even for implementation}
  957. if (cs_debuginfo in aktmoduleswitches) then
  958. begin
  959. {$IfnDef New_GDB}
  960. if assigned(current_module.globalsymtable) then
  961. begin
  962. { all types }
  963. tglobalsymtable(current_module.globalsymtable).concattypestabto(debuglist);
  964. { and all local symbols}
  965. tglobalsymtable(current_module.globalsymtable).concatstabto(debuglist);
  966. end;
  967. { all local types }
  968. tglobalsymtable(st)^.concattypestabto(debuglist);
  969. { and all local symbols}
  970. st^.concatstabto(debuglist);
  971. {$else New_GDB}
  972. write_gdb_info;
  973. {$endIf Def New_GDB}
  974. end;
  975. {$endif GDB}
  976. reset_global_defs;
  977. if (Errorcount=0) then
  978. begin
  979. { tests, if all (interface) forwards are resolved }
  980. tstoredsymtable(symtablestack).check_forwards;
  981. { check if all private fields are used }
  982. tstoredsymtable(symtablestack).allprivatesused;
  983. { remove cross unit overloads }
  984. tstoredsymtable(symtablestack).unchain_overloaded;
  985. end;
  986. {$ifdef GDB}
  987. tglobalsymtable(symtablestack).is_stab_written:=false;
  988. {$endif GDB}
  989. { leave when we got an error }
  990. if (Errorcount>0) and not status.skip_error then
  991. begin
  992. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  993. status.skip_error:=true;
  994. exit;
  995. end;
  996. { generate imports }
  997. if current_module.uses_imports then
  998. importlib.generatelib;
  999. { insert own objectfile, or say that it's in a library
  1000. (no check for an .o when loading) }
  1001. if is_assembler_generated then
  1002. insertobjectfile
  1003. else
  1004. current_module.flags:=current_module.flags or uf_no_link;
  1005. if cs_local_browser in aktmoduleswitches then
  1006. current_module.localsymtable:=refsymtable;
  1007. {$ifdef GDB}
  1008. pu:=tused_unit(usedunits.first);
  1009. while assigned(pu) do
  1010. begin
  1011. if assigned(pu.u.globalsymtable) then
  1012. tglobalsymtable(pu.u.globalsymtable).is_stab_written:=false;
  1013. pu:=tused_unit(pu.next);
  1014. end;
  1015. {$endif GDB}
  1016. if is_assembler_generated then
  1017. begin
  1018. { finish asmlist by adding segment starts }
  1019. insertsegment;
  1020. { assemble }
  1021. create_objectfile;
  1022. end;
  1023. { Write out the ppufile after the object file has been created }
  1024. store_interface_crc:=current_module.interface_crc;
  1025. store_crc:=current_module.crc;
  1026. if (Errorcount=0) then
  1027. tppumodule(current_module).writeppu;
  1028. if not(cs_compilesystem in aktmoduleswitches) then
  1029. if store_interface_crc<>current_module.interface_crc then
  1030. Message1(unit_u_interface_crc_changed,current_module.ppufilename^);
  1031. {$ifdef EXTDEBUG}
  1032. if not(cs_compilesystem in aktmoduleswitches) then
  1033. if (store_crc<>current_module.crc) and simplify_ppu then
  1034. Message1(unit_u_implementation_crc_changed,current_module.ppufilename^);
  1035. {$endif EXTDEBUG}
  1036. { remove static symtable (=refsymtable) here to save some mem }
  1037. if not (cs_local_browser in aktmoduleswitches) then
  1038. begin
  1039. st.free;
  1040. current_module.localsymtable:=nil;
  1041. end;
  1042. RestoreUnitSyms;
  1043. { leave when we got an error }
  1044. if (Errorcount>0) and not status.skip_error then
  1045. begin
  1046. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1047. status.skip_error:=true;
  1048. exit;
  1049. end;
  1050. initfinalcode.free;
  1051. Message1(unit_u_finished_compiling,current_module.modulename^);
  1052. end;
  1053. procedure proc_program(islibrary : boolean);
  1054. var
  1055. main_file: tinputfile;
  1056. st : tsymtable;
  1057. hp : tmodule;
  1058. initfinalcode : taasmoutput;
  1059. pd : tprocdef;
  1060. begin
  1061. initfinalcode:=taasmoutput.create;
  1062. DLLsource:=islibrary;
  1063. Status.IsLibrary:=IsLibrary;
  1064. Status.IsExe:=true;
  1065. parse_only:=false;
  1066. { relocation works only without stabs under win32 !! PM }
  1067. { internal assembler uses rva for stabs info
  1068. so it should work with relocated DLLs }
  1069. if RelocSection and
  1070. (target_info.system in [system_i386_win32,system_i386_wdosx]) and
  1071. (target_info.assem<>as_i386_pecoff) then
  1072. begin
  1073. include(aktglobalswitches,cs_link_strip);
  1074. { Warning stabs info does not work with reloc section !! }
  1075. if cs_debuginfo in aktmoduleswitches then
  1076. begin
  1077. Message1(parser_w_parser_reloc_no_debug,current_module.mainsource^);
  1078. Message(parser_w_parser_win32_debug_needs_WN);
  1079. exclude(aktmoduleswitches,cs_debuginfo);
  1080. end;
  1081. end;
  1082. { get correct output names }
  1083. main_file := current_scanner.inputfile;
  1084. while assigned(main_file.next) do
  1085. main_file := main_file.next;
  1086. current_module.SetFileName(main_file.path^+main_file.name^,true);
  1087. if islibrary then
  1088. begin
  1089. consume(_LIBRARY);
  1090. stringdispose(current_module.modulename);
  1091. current_module.modulename:=stringdup(pattern);
  1092. current_module.islibrary:=true;
  1093. exportlib.preparelib(pattern);
  1094. consume(_ID);
  1095. consume(_SEMICOLON);
  1096. end
  1097. else
  1098. { is there an program head ? }
  1099. if token=_PROGRAM then
  1100. begin
  1101. consume(_PROGRAM);
  1102. stringdispose(current_module.modulename);
  1103. stringdispose(current_module.realmodulename);
  1104. current_module.modulename:=stringdup(pattern);
  1105. current_module.realmodulename:=stringdup(orgpattern);
  1106. if (target_info.system in [system_i386_WIN32,system_i386_wdosx]) then
  1107. exportlib.preparelib(pattern);
  1108. consume(_ID);
  1109. if token=_LKLAMMER then
  1110. begin
  1111. consume(_LKLAMMER);
  1112. repeat
  1113. consume(_ID);
  1114. until not try_to_consume(_COMMA);
  1115. consume(_RKLAMMER);
  1116. end;
  1117. consume(_SEMICOLON);
  1118. end
  1119. else if (target_info.system in [system_i386_WIN32,system_i386_wdosx]) then
  1120. exportlib.preparelib(current_module.modulename^);
  1121. { global switches are read, so further changes aren't allowed }
  1122. current_module.in_global:=false;
  1123. { setup things using the global switches }
  1124. setupglobalswitches;
  1125. { set implementation flag }
  1126. current_module.in_interface:=false;
  1127. current_module.interface_compiled:=true;
  1128. { insert after the unit symbol tables the static symbol table }
  1129. { of the program }
  1130. st:=tstaticsymtable.create(current_module.modulename^);;
  1131. current_module.localsymtable:=st;
  1132. refsymtable:=st;
  1133. { load standard units (system,objpas,profile unit) }
  1134. loaddefaultunits;
  1135. {Load the units used by the program we compile.}
  1136. if token=_USES then
  1137. loadunits;
  1138. tstoredsymtable(symtablestack).chainoperators;
  1139. { reset ranges/stabs in exported definitions }
  1140. reset_global_defs;
  1141. { All units are read, now give them a number }
  1142. current_module.numberunits;
  1143. {Insert the name of the main program into the symbol table.}
  1144. if current_module.realmodulename^<>'' then
  1145. st.insert(tunitsym.create(current_module.realmodulename^,st));
  1146. { ...is also constsymtable, this is the symtable where }
  1147. { the elements of enumeration types are inserted }
  1148. constsymtable:=st;
  1149. Message1(parser_u_parsing_implementation,current_module.mainsource^);
  1150. { The program intialization needs an alias, so it can be called
  1151. from the bootstrap code.}
  1152. if islibrary then
  1153. begin
  1154. pd:=create_main_proc(current_module.modulename^+'_main',potype_proginit,st);
  1155. { Win32 startup code needs a single name }
  1156. // if (target_info.system in [system_i386_win32,system_i386_wdosx]) then
  1157. pd.aliasnames.insert('PASCALMAIN');
  1158. end
  1159. else
  1160. begin
  1161. pd:=create_main_proc('main',potype_proginit,st);
  1162. pd.aliasnames.insert('PASCALMAIN');
  1163. end;
  1164. tcgprocinfo(current_procinfo).parse_body;
  1165. tcgprocinfo(current_procinfo).generate_code;
  1166. tcgprocinfo(current_procinfo).resetprocdef;
  1167. release_main_proc(pd);
  1168. { should we force unit initialization? }
  1169. if tstaticsymtable(current_module.localsymtable).needs_init_final then
  1170. begin
  1171. { initialize section }
  1172. gen_implicit_initfinal(initfinalcode,uf_init,st);
  1173. codesegment.concatlist(initfinalcode);
  1174. { finalize section }
  1175. gen_implicit_initfinal(initfinalcode,uf_finalize,st);
  1176. codesegment.concatlist(initfinalcode);
  1177. end;
  1178. { Add symbol to the exports section for win32 so smartlinking a
  1179. DLL will include the edata section }
  1180. if assigned(exportlib) and
  1181. (target_info.system in [system_i386_win32,system_i386_wdosx]) and
  1182. assigned(current_module._exports.first) then
  1183. codesegment.concat(tai_const_symbol.create(exportlib.edatalabel));
  1184. If ResourceStrings.ResStrCount>0 then
  1185. begin
  1186. ResourceStrings.CreateResourceStringList;
  1187. { only write if no errors found }
  1188. if (Errorcount=0) then
  1189. ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
  1190. end;
  1191. { finalize? }
  1192. if token=_FINALIZATION then
  1193. begin
  1194. { set module options }
  1195. current_module.flags:=current_module.flags or uf_finalize;
  1196. { Compile the finalize }
  1197. pd:=create_main_proc(current_module.modulename^+'_finalize',potype_unitfinalize,st);
  1198. pd.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
  1199. tcgprocinfo(current_procinfo).parse_body;
  1200. tcgprocinfo(current_procinfo).generate_code;
  1201. tcgprocinfo(current_procinfo).resetprocdef;
  1202. release_main_proc(pd);
  1203. end;
  1204. { consume the last point }
  1205. consume(_POINT);
  1206. {$ifdef New_GDB}
  1207. write_gdb_info;
  1208. {$endIf Def New_GDB}
  1209. { leave when we got an error }
  1210. if (Errorcount>0) and not status.skip_error then
  1211. begin
  1212. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1213. status.skip_error:=true;
  1214. exit;
  1215. end;
  1216. { test static symtable }
  1217. if (Errorcount=0) then
  1218. begin
  1219. tstoredsymtable(st).allsymbolsused;
  1220. tstoredsymtable(st).allunitsused;
  1221. tstoredsymtable(st).allprivatesused;
  1222. end;
  1223. { generate a list of threadvars }
  1224. InsertThreadvars;
  1225. { generate imports }
  1226. if current_module.uses_imports then
  1227. importlib.generatelib;
  1228. if islibrary or
  1229. (target_info.system in [system_i386_WIN32,system_i386_wdosx]) or
  1230. (target_info.system=system_i386_NETWARE) then
  1231. exportlib.generatelib;
  1232. { insert Tables and Heap }
  1233. insertThreadVarTablesTable;
  1234. insertResourceTablesTable;
  1235. insertinitfinaltable;
  1236. insertheap;
  1237. insertstacklength;
  1238. // datasize:=symtablestack.datasize;
  1239. { finish asmlist by adding segment starts }
  1240. insertsegment;
  1241. { insert own objectfile }
  1242. insertobjectfile;
  1243. { assemble and link }
  1244. create_objectfile;
  1245. { leave when we got an error }
  1246. if (Errorcount>0) and not status.skip_error then
  1247. begin
  1248. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1249. status.skip_error:=true;
  1250. exit;
  1251. end;
  1252. { create the executable when we are at level 1 }
  1253. if (compile_level=1) then
  1254. begin
  1255. { insert all .o files from all loaded units }
  1256. hp:=tmodule(loaded_units.first);
  1257. while assigned(hp) do
  1258. begin
  1259. linker.AddModuleFiles(hp);
  1260. hp:=tmodule(hp.next);
  1261. end;
  1262. { write .def file }
  1263. if (cs_link_deffile in aktglobalswitches) then
  1264. deffile.writefile;
  1265. { finally we can create a executable }
  1266. if (not current_module.is_unit) then
  1267. begin
  1268. if DLLSource then
  1269. linker.MakeSharedLibrary
  1270. else
  1271. linker.MakeExecutable;
  1272. end;
  1273. end;
  1274. initfinalcode.free;
  1275. end;
  1276. end.
  1277. {
  1278. $Log$
  1279. Revision 1.126 2003-09-23 18:03:08 peter
  1280. * add missing release of main_proc
  1281. Revision 1.125 2003/09/23 17:56:05 peter
  1282. * locals and paras are allocated in the code generation
  1283. * tvarsym.localloc contains the location of para/local when
  1284. generating code for the current procedure
  1285. Revision 1.124 2003/09/09 20:59:27 daniel
  1286. * Adding register allocation order
  1287. Revision 1.123 2003/09/09 15:55:44 peter
  1288. * use register with least interferences in spillregister
  1289. Revision 1.122 2003/09/07 22:09:35 peter
  1290. * preparations for different default calling conventions
  1291. * various RA fixes
  1292. Revision 1.121 2003/09/05 17:41:12 florian
  1293. * merged Wiktor's Watcom patches in 1.1
  1294. Revision 1.120 2003/08/23 22:29:24 peter
  1295. * reload flagged units when interface is loaded
  1296. Revision 1.119 2003/08/21 14:47:41 peter
  1297. * remove convert_registers
  1298. Revision 1.118 2003/08/20 17:48:49 peter
  1299. * fixed stackalloc to not allocate localst.datasize twice
  1300. * order of stackalloc code fixed for implicit init/final
  1301. Revision 1.117 2003/08/20 09:07:00 daniel
  1302. * New register coding now mandatory, some more convert_registers calls
  1303. removed.
  1304. Revision 1.116 2003/07/23 11:04:15 jonas
  1305. * split en_exit_code into a part that may allocate a register and a part
  1306. that doesn't, so the former can be done before the register colouring
  1307. has been performed
  1308. Revision 1.115 2003/07/06 17:58:22 peter
  1309. * framepointer fixes for sparc
  1310. * parent framepointer code more generic
  1311. Revision 1.114 2003/06/13 21:19:31 peter
  1312. * current_procdef removed, use current_procinfo.procdef instead
  1313. Revision 1.113 2003/06/09 12:23:30 peter
  1314. * init/final of procedure data splitted from genentrycode
  1315. * use asmnode getposition to insert final at the correct position
  1316. als for the implicit try...finally
  1317. Revision 1.112 2003/06/07 20:26:32 peter
  1318. * re-resolving added instead of reloading from ppu
  1319. * tderef object added to store deref info for resolving
  1320. Revision 1.111 2003/06/03 20:21:45 mazen
  1321. - removed unneeded ifdefs
  1322. - removed unneeded cases for sparc and x86_64
  1323. Revision 1.110 2003/06/03 13:01:59 daniel
  1324. * Register allocator finished
  1325. Revision 1.109 2003/05/26 21:17:17 peter
  1326. * procinlinenode removed
  1327. * aktexit2label removed, fast exit removed
  1328. + tcallnode.inlined_pass_2 added
  1329. Revision 1.108 2003/05/25 10:27:12 peter
  1330. * moved Comment calls to messge file
  1331. Revision 1.107 2003/05/22 21:31:35 peter
  1332. * defer codegeneration for nested procedures
  1333. Revision 1.106 2003/05/15 18:58:53 peter
  1334. * removed selfpointer_offset, vmtpointer_offset
  1335. * tvarsym.adjusted_address
  1336. * address in localsymtable is now in the real direction
  1337. * removed some obsolete globals
  1338. Revision 1.105 2003/05/11 19:31:28 florian
  1339. * fixed implicit init/final code for units, stack frame was wrong for ppc
  1340. Revision 1.104 2003/04/28 21:19:02 peter
  1341. * fix stabs generation for implicit initfinal
  1342. Revision 1.103 2003/04/27 11:21:34 peter
  1343. * aktprocdef renamed to current_procinfo.procdef
  1344. * procinfo renamed to current_procinfo
  1345. * procinfo will now be stored in current_module so it can be
  1346. cleaned up properly
  1347. * gen_main_procsym changed to create_main_proc and release_main_proc
  1348. to also generate a tprocinfo structure
  1349. * fixed unit implicit initfinal
  1350. Revision 1.102 2003/04/27 07:29:50 peter
  1351. * current_procinfo.procdef cleanup, current_procdef is now always nil when parsing
  1352. a new procdef declaration
  1353. * aktprocsym removed
  1354. * lexlevel removed, use symtable.symtablelevel instead
  1355. * implicit init/final code uses the normal genentry/genexit
  1356. * funcret state checking updated for new funcret handling
  1357. Revision 1.101 2003/04/23 12:35:34 florian
  1358. * fixed several issues with powerpc
  1359. + applied a patch from Jonas for nested function calls (PowerPC only)
  1360. * ...
  1361. Revision 1.100 2003/04/12 15:13:03 peter
  1362. * Use the original unitname when defining a unitsym
  1363. Revision 1.99 2003/03/23 23:21:42 hajny
  1364. + emx target added
  1365. Revision 1.98 2003/03/17 22:20:08 peter
  1366. *** empty log message ***
  1367. Revision 1.97 2003/03/17 13:36:39 peter
  1368. * fix import linking under linux
  1369. Revision 1.96 2003/02/19 22:00:14 daniel
  1370. * Code generator converted to new register notation
  1371. - Horribily outdated todo.txt removed
  1372. Revision 1.95 2003/02/06 22:36:55 mazen
  1373. * fixing bug related to errornous program main entry stack frame
  1374. Revision 1.94 2003/01/30 21:46:20 peter
  1375. * tai_const_symbol.createdataname added
  1376. Revision 1.93 2003/01/11 11:19:54 hajny
  1377. * correction from rev. 1.88 put back
  1378. Revision 1.92 2003/01/08 18:43:56 daniel
  1379. * Tregister changed into a record
  1380. Revision 1.91 2003/01/05 13:36:53 florian
  1381. * x86-64 compiles
  1382. + very basic support for float128 type (x86-64 only)
  1383. Revision 1.90 2002/12/29 18:17:23 peter
  1384. * insert unitsym with the name as specified in the uses list
  1385. Revision 1.89 2002/12/29 14:57:50 peter
  1386. * unit loading changed to first register units and load them
  1387. afterwards. This is needed to support uses xxx in yyy correctly
  1388. * unit dependency check fixed
  1389. Revision 1.88 2002/12/27 19:09:33 hajny
  1390. * another (hopefully final ;-) ) fix for not linked import libraries for units with no code
  1391. Revision 1.87 2002/12/24 23:32:56 peter
  1392. * Use FixFilename for specified unit sourcefile in uses
  1393. Revision 1.86 2002/12/06 16:56:58 peter
  1394. * only compile cs_fp_emulation support when cpufpuemu is defined
  1395. * define cpufpuemu for m68k only
  1396. Revision 1.85 2002/11/30 21:32:24 carl
  1397. + Add loading of softfpu in emulation mode
  1398. + Correct routine call for softfpu
  1399. * Extended type must also be defined even with softfpu
  1400. Revision 1.84 2002/11/15 01:58:53 peter
  1401. * merged changes from 1.0.7 up to 04-11
  1402. - -V option for generating bug report tracing
  1403. - more tracing for option parsing
  1404. - errors for cdecl and high()
  1405. - win32 import stabs
  1406. - win32 records<=8 are returned in eax:edx (turned off by default)
  1407. - heaptrc update
  1408. - more info for temp management in .s file with EXTDEBUG
  1409. Revision 1.83 2002/11/09 15:33:26 carl
  1410. * major alignment updates
  1411. Revision 1.82 2002/10/16 06:32:52 michael
  1412. + Renamed thread unit to systhrds
  1413. Revision 1.81 2002/10/14 19:42:34 peter
  1414. * only use init tables for threadvars
  1415. Revision 1.80 2002/10/06 19:41:30 peter
  1416. * Add finalization of typed consts
  1417. * Finalization of globals in the main program
  1418. Revision 1.79 2002/09/09 17:34:15 peter
  1419. * tdicationary.replace added to replace and item in a dictionary. This
  1420. is only allowed for the same name
  1421. * varsyms are inserted in symtable before the types are parsed. This
  1422. fixes the long standing "var longint : longint" bug
  1423. - consume_idlist and idstringlist removed. The loops are inserted
  1424. at the callers place and uses the symtable for duplicate id checking
  1425. Revision 1.78 2002/09/07 15:25:07 peter
  1426. * old logs removed and tabs fixed
  1427. Revision 1.77 2002/09/03 16:26:27 daniel
  1428. * Make Tprocdef.defs protected
  1429. Revision 1.76 2002/09/02 18:46:26 peter
  1430. * insert PASCALMAIN in library for Win32 only
  1431. Revision 1.75 2002/08/31 15:59:30 florian
  1432. + HEAP* stuff must be generated for Linux/PPC as well
  1433. + direct assembler reader searches now global and static symtables as well
  1434. Revision 1.74 2002/08/25 19:25:20 peter
  1435. * sym.insert_in_data removed
  1436. * symtable.insertvardata/insertconstdata added
  1437. * removed insert_in_data call from symtable.insert, it needs to be
  1438. called separatly. This allows to deref the address calculation
  1439. * procedures now calculate the parast addresses after the procedure
  1440. directives are parsed. This fixes the cdecl parast problem
  1441. * push_addr_param has an extra argument that specifies if cdecl is used
  1442. or not
  1443. Revision 1.73 2002/08/18 20:06:25 peter
  1444. * inlining is now also allowed in interface
  1445. * renamed write/load to ppuwrite/ppuload
  1446. * tnode storing in ppu
  1447. * nld,ncon,nbas are already updated for storing in ppu
  1448. Revision 1.72 2002/08/17 09:23:39 florian
  1449. * first part of procinfo rewrite
  1450. Revision 1.71 2002/08/11 13:24:12 peter
  1451. * saving of asmsymbols in ppu supported
  1452. * asmsymbollist global is removed and moved into a new class
  1453. tasmlibrarydata that will hold the info of a .a file which
  1454. corresponds with a single module. Added librarydata to tmodule
  1455. to keep the library info stored for the module. In the future the
  1456. objectfiles will also be stored to the tasmlibrarydata class
  1457. * all getlabel/newasmsymbol and friends are moved to the new class
  1458. Revision 1.70 2002/08/10 14:46:29 carl
  1459. + moved target_cpu_string to cpuinfo
  1460. * renamed asmmode enum.
  1461. * assembler reader has now less ifdef's
  1462. * move from nppcmem.pas -> ncgmem.pas vec. node.
  1463. Revision 1.69 2002/07/26 21:15:41 florian
  1464. * rewrote the system handling
  1465. Revision 1.68 2002/07/04 20:43:01 florian
  1466. * first x86-64 patches
  1467. Revision 1.67 2002/07/01 18:46:25 peter
  1468. * internal linker
  1469. * reorganized aasm layer
  1470. Revision 1.66 2002/05/16 19:46:43 carl
  1471. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  1472. + try to fix temp allocation (still in ifdef)
  1473. + generic constructor calls
  1474. + start of tassembler / tmodulebase class cleanup
  1475. Revision 1.65 2002/05/14 19:34:49 peter
  1476. * removed old logs and updated copyright year
  1477. Revision 1.64 2002/05/12 16:53:09 peter
  1478. * moved entry and exitcode to ncgutil and cgobj
  1479. * foreach gets extra argument for passing local data to the
  1480. iterator function
  1481. * -CR checks also class typecasts at runtime by changing them
  1482. into as
  1483. * fixed compiler to cycle with the -CR option
  1484. * fixed stabs with elf writer, finally the global variables can
  1485. be watched
  1486. * removed a lot of routines from cga unit and replaced them by
  1487. calls to cgobj
  1488. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  1489. u32bit then the other is typecasted also to u32bit without giving
  1490. a rangecheck warning/error.
  1491. * fixed pascal calling method with reversing also the high tree in
  1492. the parast, detected by tcalcst3 test
  1493. Revision 1.63 2002/05/06 19:54:50 carl
  1494. + added more patches from Mazen for SPARC port
  1495. Revision 1.62 2002/04/20 21:32:24 carl
  1496. + generic FPC_CHECKPOINTER
  1497. + first parameter offset in stack now portable
  1498. * rename some constants
  1499. + move some cpu stuff to other units
  1500. - remove unused constents
  1501. * fix stacksize for some targets
  1502. * fix generic size problems which depend now on EXTEND_SIZE constant
  1503. Revision 1.61 2002/04/19 15:46:02 peter
  1504. * mangledname rewrite, tprocdef.mangledname is now created dynamicly
  1505. in most cases and not written to the ppu
  1506. * add mangeledname_prefix() routine to generate the prefix of
  1507. manglednames depending on the current procedure, object and module
  1508. * removed static procprefix since the mangledname is now build only
  1509. on demand from tprocdef.mangledname
  1510. Revision 1.60 2002/04/14 16:53:10 carl
  1511. + align code section and data section according to alignment rules
  1512. Revision 1.59 2002/04/07 17:58:38 carl
  1513. + generic stack checking
  1514. Revision 1.58 2002/04/04 19:06:03 peter
  1515. * removed unused units
  1516. * use tlocation.size in cg.a_*loc*() routines
  1517. }