pmodules.pas 59 KB

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