pmodules.pas 59 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 defines.inc}
  20. { close old_current_ppu on system that are
  21. short on file handles like DOS system PM }
  22. {$ifdef GO32V1}
  23. {$define SHORT_ON_FILE_HANDLES}
  24. {$endif GO32V1}
  25. {$ifdef GO32V2}
  26. {$define SHORT_ON_FILE_HANDLES}
  27. {$endif GO32V2}
  28. {$define New_GDB}
  29. interface
  30. procedure proc_unit;
  31. procedure proc_program(islibrary : boolean);
  32. implementation
  33. uses
  34. globtype,version,systems,tokens,
  35. cutils,cobjects,comphook,
  36. globals,verbose,fmodule,finput,
  37. symconst,symbase,symppu,symdef,symsym,symtable,aasm,types,
  38. {$ifdef newcg}
  39. cgbase,
  40. {$else newcg}
  41. hcodegen,
  42. {$ifdef i386}
  43. cgai386,
  44. {$endif i386}
  45. {$endif newcg}
  46. link,assemble,import,export,gendef,ppu,comprsrc,
  47. cresstr,cpubase,cpuasm,
  48. {$ifdef GDB}
  49. gdb,
  50. {$endif GDB}
  51. scanner,pbase,psystem,psub,parser;
  52. procedure create_objectfile;
  53. begin
  54. { create the .s file and assemble it }
  55. GenerateAsm(false);
  56. { Also create a smartlinked version ? }
  57. if (cs_create_smart in aktmoduleswitches) then
  58. begin
  59. { regenerate the importssection for win32 }
  60. if assigned(importssection) and
  61. (target_info.target=target_i386_win32) then
  62. begin
  63. importsSection.clear;
  64. importlib.generatesmartlib;
  65. end;
  66. GenerateAsm(true);
  67. if target_asm.needar then
  68. Linker.MakeStaticLibrary;
  69. end;
  70. { resource files }
  71. CompileResourceFiles;
  72. end;
  73. procedure insertobjectfile;
  74. { Insert the used object file for this unit in the used list for this unit }
  75. begin
  76. current_module.linkunitofiles.add(current_module.objfilename^,link_static);
  77. current_module.flags:=current_module.flags or uf_static_linked;
  78. if (cs_create_smart in aktmoduleswitches) then
  79. begin
  80. current_module.linkunitstaticlibs.add(current_module.staticlibfilename^,link_smart);
  81. current_module.flags:=current_module.flags or uf_smart_linked;
  82. end;
  83. end;
  84. procedure insertsegment;
  85. procedure fixseg(p:TAAsmoutput;sec:tsection);
  86. begin
  87. p.insert(Tai_section.Create(sec));
  88. if (cs_create_smart in aktmoduleswitches) then
  89. p.insert(Tai_cut.Create);
  90. p.concat(Tai_section.Create(sec_none));
  91. end;
  92. begin
  93. { Insert Ident of the compiler }
  94. if (not (cs_create_smart in aktmoduleswitches))
  95. {$ifndef EXTDEBUG}
  96. and (not current_module.is_unit)
  97. {$endif}
  98. then
  99. begin
  100. dataSegment.insert(Tai_align.Create(4));
  101. dataSegment.insert(Tai_string.Create('FPC '+full_version_string+
  102. ' ['+date_string+'] for '+target_cpu_string+' - '+target_info.short_name));
  103. end;
  104. { finish codesegment }
  105. codeSegment.concat(Tai_align.Create(16));
  106. { Insert start and end of sections }
  107. fixseg(codesegment,sec_code);
  108. fixseg(datasegment,sec_data);
  109. fixseg(bsssegment,sec_bss);
  110. { we should use .rdata section for these two no ? }
  111. { .rdata is a read only data section (PM) }
  112. fixseg(rttilist,sec_data);
  113. fixseg(consts,sec_data);
  114. if assigned(resourcestringlist) then
  115. fixseg(resourcestringlist,sec_data);
  116. {$ifdef GDB}
  117. if assigned(debuglist) then
  118. begin
  119. debugList.insert(Tai_symbol.Createname('gcc2_compiled',0));
  120. debugList.insert(Tai_symbol.Createname('fpc_compiled',0));
  121. fixseg(debuglist,sec_code);
  122. end;
  123. {$endif GDB}
  124. end;
  125. Procedure InsertResourceTablesTable;
  126. var
  127. hp : tused_unit;
  128. ResourceStringTables : taasmoutput;
  129. count : longint;
  130. begin
  131. ResourceStringTables:=TAAsmOutput.Create;
  132. count:=0;
  133. hp:=tused_unit(usedunits.first);
  134. while assigned(hp) do
  135. begin
  136. If (hp.u.flags and uf_has_resources)=uf_has_resources then
  137. begin
  138. ResourceStringTables.concat(Tai_const_symbol.Createname(hp.u.modulename^+'_RESOURCESTRINGLIST'));
  139. inc(count);
  140. end;
  141. hp:=tused_unit(hp.next);
  142. end;
  143. { Add program resources, if any }
  144. If ResourceStringList<>Nil then
  145. begin
  146. ResourceStringTables.concat(Tai_const_symbol.Createname(current_module.modulename^+'_RESOURCESTRINGLIST'));
  147. Inc(Count);
  148. end;
  149. { TableCount }
  150. { doesn't work because of bug in the compiler !! (JM)
  151. With ResourceStringTables do}
  152. begin
  153. ResourceStringTables.insert(Tai_const.Create_32bit(count));
  154. ResourceStringTables.insert(Tai_symbol.Createdataname_global('FPC_RESOURCESTRINGTABLES',0));
  155. ResourceStringTables.concat(Tai_symbol_end.Createname('FPC_RESOURCESTRINGTABLES'));
  156. end;
  157. { insert in data segment }
  158. if (cs_create_smart in aktmoduleswitches) then
  159. dataSegment.concat(Tai_cut.Create);
  160. dataSegment.concatlist(ResourceStringTables);
  161. ResourceStringTables.free;
  162. end;
  163. procedure InsertInitFinalTable;
  164. var
  165. hp : tused_unit;
  166. unitinits : taasmoutput;
  167. count : longint;
  168. begin
  169. unitinits:=TAAsmOutput.Create;
  170. count:=0;
  171. hp:=tused_unit(usedunits.first);
  172. while assigned(hp) do
  173. begin
  174. { call the unit init code and make it external }
  175. if (hp.u.flags and (uf_init or uf_finalize))<>0 then
  176. begin
  177. if (hp.u.flags and uf_init)<>0 then
  178. unitinits.concat(Tai_const_symbol.Createname('INIT$$'+hp.u.modulename^))
  179. else
  180. unitinits.concat(Tai_const.Create_32bit(0));
  181. if (hp.u.flags and uf_finalize)<>0 then
  182. unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+hp.u.modulename^))
  183. else
  184. unitinits.concat(Tai_const.Create_32bit(0));
  185. inc(count);
  186. end;
  187. hp:=tused_unit(hp.next);
  188. end;
  189. if current_module.islibrary then
  190. if (current_module.flags and uf_finalize)<>0 then
  191. begin
  192. { INIT code is done by PASCALMAIN calling }
  193. unitinits.concat(Tai_const.Create_32bit(0));
  194. unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+current_module.modulename^));
  195. inc(count);
  196. end;
  197. { TableCount,InitCount }
  198. unitinits.insert(Tai_const.Create_32bit(0));
  199. unitinits.insert(Tai_const.Create_32bit(count));
  200. unitinits.insert(Tai_symbol.Createdataname_global('INITFINAL',0));
  201. unitinits.concat(Tai_symbol_end.Createname('INITFINAL'));
  202. { insert in data segment }
  203. if (cs_create_smart in aktmoduleswitches) then
  204. dataSegment.concat(Tai_cut.Create);
  205. dataSegment.concatlist(unitinits);
  206. unitinits.free;
  207. end;
  208. procedure insertheap;
  209. begin
  210. if (cs_create_smart in aktmoduleswitches) then
  211. begin
  212. bssSegment.concat(Tai_cut.Create);
  213. dataSegment.concat(Tai_cut.Create);
  214. end;
  215. { On the Macintosh Classic M68k Architecture
  216. The Heap variable is simply a POINTER to the
  217. real HEAP. The HEAP must be set up by the RTL
  218. and must store the pointer in this value.
  219. On OS/2 the heap is also intialized by the RTL. We do
  220. not output a pointer }
  221. case target_info.target of
  222. {$ifdef i386}
  223. target_i386_OS2:
  224. ;
  225. {$endif i386}
  226. {$ifdef alpha}
  227. target_alpha_linux:
  228. ;
  229. {$endif alpha}
  230. {$ifdef powerpc}
  231. target_powerpc_linux:
  232. ;
  233. {$endif powerpc}
  234. {$ifdef m68k}
  235. target_m68k_Mac:
  236. bssSegment.concat(Tai_datablock.Create_global('HEAP',4));
  237. target_m68k_PalmOS:
  238. ;
  239. {$endif m68k}
  240. else
  241. bssSegment.concat(Tai_datablock.Create_global('HEAP',heapsize));
  242. end;
  243. {$ifdef m68k}
  244. if target_info.target<>target_m68k_PalmOS then
  245. begin
  246. dataSegment.concat(Tai_symbol.Createdataname_global('HEAP_SIZE',0));
  247. dataSegment.concat(Tai_const.Create_32bit(heapsize));
  248. end;
  249. {$else m68k}
  250. dataSegment.concat(Tai_symbol.Createdataname_global('HEAPSIZE',4));
  251. dataSegment.concat(Tai_const.Create_32bit(heapsize));
  252. {$endif m68k}
  253. end;
  254. procedure inserttargetspecific;
  255. begin
  256. case target_info.target of
  257. {$ifdef alpha}
  258. target_alpha_linux:
  259. ;
  260. {$endif alpha}
  261. {$ifdef powerpc}
  262. target_powerpc_linux:
  263. ;
  264. {$endif powerpc}
  265. {$ifdef i386}
  266. target_i386_GO32V2 :
  267. begin
  268. { stacksize can be specified }
  269. dataSegment.concat(Tai_symbol.Createdataname_global('__stklen',4));
  270. dataSegment.concat(Tai_const.Create_32bit(stacksize));
  271. end;
  272. {$endif i386}
  273. {$ifdef m68k}
  274. target_m68k_Atari :
  275. begin
  276. { stacksize can be specified }
  277. dataSegment.concat(Tai_symbol.Createdataname_global('__stklen',4));
  278. dataSegment.concat(Tai_const.Create_32bit(stacksize));
  279. end;
  280. {$endif m68k}
  281. end;
  282. end;
  283. function loadunit(const s : string;compile_system:boolean) : tmodule;forward;
  284. procedure load_usedunits(compile_system:boolean);
  285. var
  286. pu : tused_unit;
  287. loaded_unit : tmodule;
  288. load_refs : boolean;
  289. nextmapentry : longint;
  290. begin
  291. load_refs:=true;
  292. { init the map }
  293. new(current_module.map);
  294. fillchar(current_module.map^,sizeof(tunitmap),#0);
  295. {$ifdef NEWMAP}
  296. current_module.map^[0]:=current_module;
  297. {$endif NEWMAP}
  298. nextmapentry:=1;
  299. { load the used units from interface }
  300. current_module.in_implementation:=false;
  301. pu:=tused_unit(current_module.used_units.first);
  302. while assigned(pu) do
  303. begin
  304. if (not pu.loaded) and (pu.in_interface) then
  305. begin
  306. loaded_unit:=loadunit(pu.name^,false);
  307. if current_module.compiled then
  308. exit;
  309. { register unit in used units }
  310. pu.u:=loaded_unit;
  311. pu.loaded:=true;
  312. { doubles are not important for that list PM }
  313. pu.u.dependent_units.concat(tdependent_unit.create(current_module));
  314. { need to recompile the current unit ? }
  315. if loaded_unit.crc<>pu.checksum then
  316. begin
  317. Message2(unit_u_recompile_crc_change,current_module.modulename^,pu.name^);
  318. current_module.recompile_reason:=rr_crcchanged;
  319. current_module.do_compile:=true;
  320. dispose(current_module.map);
  321. current_module.map:=nil;
  322. exit;
  323. end;
  324. { setup the map entry for deref }
  325. {$ifndef NEWMAP}
  326. current_module.map^[nextmapentry]:=loaded_unit.globalsymtable;
  327. {$else NEWMAP}
  328. current_module.map^[nextmapentry]:=loaded_unit;
  329. {$endif NEWMAP}
  330. inc(nextmapentry);
  331. if nextmapentry>maxunits then
  332. Message(unit_f_too_much_units);
  333. end;
  334. pu:=tused_unit(pu.next);
  335. end;
  336. { ok, now load the unit }
  337. current_module.globalsymtable:=new(punitsymtable,loadasunit);
  338. { now only read the implementation part }
  339. current_module.in_implementation:=true;
  340. { load the used units from implementation }
  341. pu:=tused_unit(current_module.used_units.first);
  342. while assigned(pu) do
  343. begin
  344. if (not pu.loaded) and (not pu.in_interface) then
  345. begin
  346. loaded_unit:=loadunit(pu.name^,false);
  347. if current_module.compiled then
  348. exit;
  349. { register unit in used units }
  350. pu.u:=loaded_unit;
  351. pu.loaded:=true;
  352. { need to recompile the current unit ? }
  353. if (loaded_unit.interface_crc<>pu.interface_checksum) {and
  354. not(current_module.in_second_compile) } then
  355. begin
  356. Message2(unit_u_recompile_crc_change,current_module.modulename^,pu.name^+' {impl}');
  357. current_module.recompile_reason:=rr_crcchanged;
  358. current_module.do_compile:=true;
  359. dispose(current_module.map);
  360. current_module.map:=nil;
  361. exit;
  362. end;
  363. { setup the map entry for deref }
  364. {$ifndef NEWMAP}
  365. current_module.map^[nextmapentry]:=loaded_unit.globalsymtable;
  366. {$else NEWMAP}
  367. current_module.map^[nextmapentry]:=loaded_unit;
  368. {$endif NEWMAP}
  369. inc(nextmapentry);
  370. if nextmapentry>maxunits then
  371. Message(unit_f_too_much_units);
  372. end;
  373. pu:=tused_unit(pu.next);
  374. end;
  375. { deref }
  376. punitsymtable(current_module.globalsymtable)^.deref;
  377. { load browser info if stored }
  378. if ((current_module.flags and uf_has_browser)<>0) and load_refs then
  379. punitsymtable(current_module.globalsymtable)^.load_symtable_refs;
  380. { remove the map, it's not needed anymore }
  381. dispose(current_module.map);
  382. current_module.map:=nil;
  383. end;
  384. function loadunit(const s : string;compile_system:boolean) : tmodule;
  385. const
  386. ImplIntf : array[boolean] of string[15]=('interface','implementation');
  387. var
  388. st : punitsymtable;
  389. second_time : boolean;
  390. old_current_ppu : pppufile;
  391. old_current_module,hp,hp2 : tmodule;
  392. name : string;{ necessary because current_module.mainsource^ is reset in compile !! }
  393. scanner : pscannerfile;
  394. procedure loadppufile;
  395. begin
  396. { load interface section }
  397. if not current_module.do_compile then
  398. load_interface;
  399. { only load units when we don't recompile }
  400. if not current_module.do_compile then
  401. load_usedunits(compile_system);
  402. { recompile if set }
  403. if current_module.do_compile then
  404. begin
  405. { we don't need the ppufile anymore }
  406. if assigned(current_module.ppufile) then
  407. begin
  408. dispose(current_module.ppufile,done);
  409. current_module.ppufile:=nil;
  410. current_ppu:=nil;
  411. end;
  412. { recompile the unit or give a fatal error if sources not available }
  413. if not(current_module.sources_avail) and
  414. not(current_module.sources_checked) then
  415. if (not current_module.search_unit(current_module.modulename^,true))
  416. and (length(current_module.modulename^)>8) then
  417. current_module.search_unit(copy(current_module.modulename^,1,8),true);
  418. if not(current_module.sources_avail) then
  419. begin
  420. hp:=current_module;
  421. current_module:=old_current_module;
  422. if hp.recompile_reason=rr_noppu then
  423. Message1(unit_f_cant_find_ppu,hp.modulename^)
  424. else
  425. Message1(unit_f_cant_compile_unit,hp.modulename^);
  426. current_module:=hp;
  427. end
  428. else
  429. begin
  430. if current_module.in_compile then
  431. begin
  432. current_module.in_second_compile:=true;
  433. Message1(parser_d_compiling_second_time,current_module.modulename^);
  434. end;
  435. current_scanner^.tempcloseinputfile;
  436. name:=current_module.mainsource^;
  437. if assigned(scanner) then
  438. scanner^.invalid:=true;
  439. compile(name,compile_system);
  440. current_module.in_second_compile:=false;
  441. if (not current_scanner^.invalid) then
  442. current_scanner^.tempopeninputfile;
  443. end;
  444. end
  445. else
  446. begin
  447. { only reassemble ? }
  448. if (current_module.do_assemble) then
  449. OnlyAsm;
  450. end;
  451. if assigned(current_module.ppufile) then
  452. begin
  453. dispose(current_module.ppufile,done);
  454. current_module.ppufile:=nil;
  455. current_ppu:=nil;
  456. end;
  457. end;
  458. var
  459. dummy : tmodule;
  460. begin
  461. old_current_module:=current_module;
  462. old_current_ppu:=current_ppu;
  463. { Info }
  464. Message3(unit_u_load_unit,current_module.modulename^,ImplIntf[current_module.in_implementation],s);
  465. { unit not found }
  466. st:=nil;
  467. dummy:=nil;
  468. { search all loaded units }
  469. hp:=tmodule(loaded_units.first);
  470. while assigned(hp) do
  471. begin
  472. if hp.modulename^=s then
  473. begin
  474. { forced to reload ? }
  475. if hp.do_reload then
  476. begin
  477. hp.do_reload:=false;
  478. break;
  479. end;
  480. { the unit is already registered }
  481. { and this means that the unit }
  482. { is already compiled }
  483. { else there is a cyclic unit use }
  484. if assigned(hp.globalsymtable) then
  485. st:=punitsymtable(hp.globalsymtable)
  486. else
  487. begin
  488. { both units in interface ? }
  489. if (not current_module.in_implementation) and (not hp.in_implementation) then
  490. begin
  491. { check for a cycle }
  492. hp2:=current_module.loaded_from;
  493. while assigned(hp2) and (hp2<>hp) do
  494. begin
  495. if hp2.in_implementation then
  496. hp2:=nil
  497. else
  498. hp2:=hp2.loaded_from;
  499. end;
  500. if assigned(hp2) then
  501. Message2(unit_f_circular_unit_reference,current_module.modulename^,hp.modulename^);
  502. end;
  503. end;
  504. break;
  505. end
  506. else if copy(hp.modulename^,1,8)=s then
  507. dummy:=hp;
  508. { the next unit }
  509. hp:=tmodule(hp.next);
  510. end;
  511. if assigned(dummy) and not assigned(hp) then
  512. Message2(unit_w_unit_name_error,s,dummy.modulename^);
  513. { the unit is not in the symtable stack }
  514. if (not assigned(st)) then
  515. begin
  516. if assigned(hp) then
  517. begin
  518. { remove the old unit }
  519. loaded_units.remove(hp);
  520. scanner:=hp.scanner;
  521. hp.reset;
  522. hp.scanner:=scanner;
  523. { try to reopen ppu }
  524. hp.search_unit(s,false);
  525. { try to load the unit a second time first }
  526. current_module:=hp;
  527. current_module.in_second_load:=true;
  528. Message1(unit_u_second_load_unit,current_module.modulename^);
  529. second_time:=true;
  530. end
  531. else
  532. { generates a new unit info record }
  533. begin
  534. current_module:=tmodule.create(s,true);
  535. scanner:=nil;
  536. second_time:=false;
  537. end;
  538. current_ppu:=current_module.ppufile;
  539. { close old_current_ppu on system that are
  540. short on file handles like DOS PM }
  541. {$ifdef SHORT_ON_FILE_HANDLES}
  542. if assigned(old_current_ppu) then
  543. old_current_ppu^.tempclose;
  544. {$endif SHORT_ON_FILE_HANDLES}
  545. { now we can register the unit }
  546. current_module.loaded_from:=old_current_module;
  547. loaded_units.insert(current_module);
  548. { now realy load the ppu }
  549. loadppufile;
  550. { set compiled flag }
  551. current_module.compiled:=true;
  552. { load return pointer }
  553. hp:=current_module;
  554. { for a second_time recompile reload all dependent units,
  555. for a first time compile register the unit _once_ }
  556. if second_time then
  557. begin
  558. { now reload all dependent units }
  559. hp2:=tmodule(loaded_units.first);
  560. while assigned(hp2) do
  561. begin
  562. if hp2.do_reload then
  563. dummy:=loadunit(hp2.modulename^,false);
  564. hp2:=tmodule(hp2.next);
  565. end;
  566. end
  567. else
  568. usedunits.concat(tused_unit.create(current_module,true));
  569. end;
  570. { set the old module }
  571. {$ifdef SHORT_ON_FILE_HANDLES}
  572. if assigned(old_current_ppu) then
  573. old_current_ppu^.tempopen;
  574. {$endif SHORT_ON_FILE_HANDLES}
  575. current_ppu:=old_current_ppu;
  576. current_module:=old_current_module;
  577. { we are back }
  578. SetCompileModule(current_module);
  579. loadunit:=hp;
  580. end;
  581. procedure loaddefaultunits;
  582. var
  583. hp : tmodule;
  584. unitsym : punitsym;
  585. begin
  586. { are we compiling the system unit? }
  587. if (cs_compilesystem in aktmoduleswitches) then
  588. begin
  589. { create system defines }
  590. createconstdefs;
  591. { we don't need to reset anything, it's already done in parser.pas }
  592. exit;
  593. end;
  594. { insert the system unit, it is allways the first }
  595. hp:=loadunit('SYSTEM',true);
  596. systemunit:=hp.globalsymtable;
  597. { it's always the first unit }
  598. systemunit^.next:=nil;
  599. symtablestack:=systemunit;
  600. { add to the used units }
  601. current_module.used_units.concat(tused_unit.create(hp,true));
  602. unitsym:=new(punitsym,init('System',systemunit));
  603. inc(unitsym^.refs);
  604. refsymtable^.insert(unitsym);
  605. { read default constant definitions }
  606. make_ref:=false;
  607. readconstdefs;
  608. { if POWER is defined in the RTL then use it for starstar overloading }
  609. {$ifdef DONOTCHAINOPERATORS}
  610. getsym('POWER',false);
  611. {$endif DONOTCHAINOPERATORS}
  612. make_ref:=true;
  613. {$ifdef DONOTCHAINOPERATORS}
  614. { Code now in chainoperators PM }
  615. if assigned(srsym) and (srsym^.typ=procsym) and (overloaded_operators[_STARSTAR]=nil) then
  616. overloaded_operators[_STARSTAR]:=pprocsym(srsym);
  617. {$endif DONOTCHAINOPERATORS}
  618. { Objpas unit? }
  619. if m_objpas in aktmodeswitches then
  620. begin
  621. hp:=loadunit('ObjPas',false);
  622. psymtable(hp.globalsymtable)^.next:=symtablestack;
  623. symtablestack:=hp.globalsymtable;
  624. { add to the used units }
  625. current_module.used_units.concat(tused_unit.create(hp,true));
  626. unitsym:=new(punitsym,init('ObjPas',hp.globalsymtable));
  627. inc(unitsym^.refs);
  628. refsymtable^.insert(unitsym);
  629. end;
  630. { Profile unit? Needed for go32v2 only }
  631. if (cs_profile in aktmoduleswitches) and (target_info.target=target_i386_go32v2) then
  632. begin
  633. hp:=loadunit('Profile',false);
  634. psymtable(hp.globalsymtable)^.next:=symtablestack;
  635. symtablestack:=hp.globalsymtable;
  636. { add to the used units }
  637. current_module.used_units.concat(tused_unit.create(hp,true));
  638. unitsym:=new(punitsym,init('Profile',hp.globalsymtable));
  639. inc(unitsym^.refs);
  640. refsymtable^.insert(unitsym);
  641. end;
  642. { Units only required for main module }
  643. if not(current_module.is_unit) then
  644. begin
  645. { Heaptrc unit }
  646. if (cs_gdb_heaptrc in aktglobalswitches) then
  647. begin
  648. hp:=loadunit('HeapTrc',false);
  649. psymtable(hp.globalsymtable)^.next:=symtablestack;
  650. symtablestack:=hp.globalsymtable;
  651. { add to the used units }
  652. current_module.used_units.concat(tused_unit.create(hp,true));
  653. unitsym:=new(punitsym,init('HeapTrc',hp.globalsymtable));
  654. inc(unitsym^.refs);
  655. refsymtable^.insert(unitsym);
  656. end;
  657. { Lineinfo unit }
  658. if (cs_gdb_lineinfo in aktglobalswitches) then
  659. begin
  660. hp:=loadunit('LineInfo',false);
  661. psymtable(hp.globalsymtable)^.next:=symtablestack;
  662. symtablestack:=hp.globalsymtable;
  663. { add to the used units }
  664. current_module.used_units.concat(tused_unit.create(hp,true));
  665. unitsym:=new(punitsym,init('LineInfo',hp.globalsymtable));
  666. inc(unitsym^.refs);
  667. refsymtable^.insert(unitsym);
  668. end;
  669. end;
  670. { save default symtablestack }
  671. defaultsymtablestack:=symtablestack;
  672. end;
  673. procedure loadunits;
  674. var
  675. s,sorg : stringid;
  676. pu,
  677. hp : tused_unit;
  678. hp2 : tmodule;
  679. hp3 : psymtable;
  680. oldprocsym:Pprocsym;
  681. unitsym : punitsym;
  682. begin
  683. oldprocsym:=aktprocsym;
  684. consume(_USES);
  685. {$ifdef DEBUG}
  686. test_symtablestack;
  687. {$endif DEBUG}
  688. repeat
  689. s:=pattern;
  690. sorg:=orgpattern;
  691. consume(_ID);
  692. { Give a warning if objpas is loaded }
  693. if s='OBJPAS' then
  694. Message(parser_w_no_objpas_use_mode);
  695. { check if the unit is already used }
  696. pu:=tused_unit(current_module.used_units.first);
  697. while assigned(pu) do
  698. begin
  699. if (pu.name^=s) then
  700. break;
  701. pu:=tused_unit(pu.next);
  702. end;
  703. { avoid uses of itself }
  704. if not assigned(pu) and (s<>current_module.modulename^) then
  705. begin
  706. { load the unit }
  707. hp2:=loadunit(s,false);
  708. { the current module uses the unit hp2 }
  709. current_module.used_units.concat(tused_unit.create(hp2,not current_module.in_implementation));
  710. tused_unit(current_module.used_units.last).in_uses:=true;
  711. if current_module.compiled then
  712. exit;
  713. unitsym:=new(punitsym,init(sorg,hp2.globalsymtable));
  714. { never claim about unused unit if
  715. there is init or finalize code PM }
  716. if (hp2.flags and (uf_init or uf_finalize))<>0 then
  717. inc(unitsym^.refs);
  718. refsymtable^.insert(unitsym);
  719. end
  720. else
  721. Message1(sym_e_duplicate_id,s);
  722. if token=_COMMA then
  723. begin
  724. pattern:='';
  725. consume(_COMMA);
  726. end
  727. else
  728. break;
  729. until false;
  730. consume(_SEMICOLON);
  731. { set the symtable to systemunit so it gets reorderd correctly }
  732. symtablestack:=defaultsymtablestack;
  733. { now insert the units in the symtablestack }
  734. hp:=tused_unit(current_module.used_units.first);
  735. while assigned(hp) do
  736. begin
  737. {$IfDef GDB}
  738. if (cs_debuginfo in aktmoduleswitches) and
  739. (cs_gdb_dbx in aktglobalswitches) and
  740. not hp.is_stab_written then
  741. begin
  742. punitsymtable(hp.u.globalsymtable)^.concattypestabto(debuglist);
  743. hp.is_stab_written:=true;
  744. hp.unitid:=psymtable(hp.u.globalsymtable)^.unitid;
  745. end;
  746. {$EndIf GDB}
  747. if hp.in_uses then
  748. begin
  749. hp3:=symtablestack;
  750. while assigned(hp3) do
  751. begin
  752. { insert units only once ! }
  753. if hp.u.globalsymtable=hp3 then
  754. break;
  755. hp3:=hp3^.next;
  756. { unit isn't inserted }
  757. if hp3=nil then
  758. begin
  759. psymtable(hp.u.globalsymtable)^.next:=symtablestack;
  760. symtablestack:=psymtable(hp.u.globalsymtable);
  761. {$ifdef CHAINPROCSYMS}
  762. symtablestack^.chainprocsyms;
  763. {$endif CHAINPROCSYMS}
  764. {$ifdef DEBUG}
  765. test_symtablestack;
  766. {$endif DEBUG}
  767. end;
  768. end;
  769. end;
  770. hp:=tused_unit(hp.next);
  771. end;
  772. aktprocsym:=oldprocsym;
  773. end;
  774. procedure write_gdb_info;
  775. {$IfDef GDB}
  776. var
  777. hp : tused_unit;
  778. begin
  779. if not (cs_debuginfo in aktmoduleswitches) then
  780. exit;
  781. if (cs_gdb_dbx in aktglobalswitches) then
  782. begin
  783. debugList.concat(Tai_asm_comment.Create(strpnew('EINCL of global '+
  784. punitsymtable(current_module.globalsymtable)^.name^+' has index '+
  785. tostr(punitsymtable(current_module.globalsymtable)^.unitid))));
  786. debugList.concat(Tai_stabs.Create(strpnew('"'+
  787. punitsymtable(current_module.globalsymtable)^.name^+'",'+
  788. tostr(N_EINCL)+',0,0,0')));
  789. punitsymtable(current_module.globalsymtable)^.dbx_count_ok:={true}false;
  790. dbx_counter:=punitsymtable(current_module.globalsymtable)^.prev_dbx_counter;
  791. do_count_dbx:=false;
  792. end;
  793. { now insert the units in the symtablestack }
  794. hp:=tused_unit(current_module.used_units.first);
  795. while assigned(hp) do
  796. begin
  797. if (cs_debuginfo in aktmoduleswitches) and
  798. not hp.is_stab_written then
  799. begin
  800. punitsymtable(hp.u.globalsymtable)^.concattypestabto(debuglist);
  801. hp.is_stab_written:=true;
  802. hp.unitid:=psymtable(hp.u.globalsymtable)^.unitid;
  803. end;
  804. hp:=tused_unit(hp.next);
  805. end;
  806. if current_module.in_implementation and
  807. assigned(current_module.localsymtable) then
  808. begin
  809. { all types }
  810. punitsymtable(current_module.localsymtable)^.concattypestabto(debuglist);
  811. { and all local symbols}
  812. punitsymtable(current_module.localsymtable)^.concatstabto(debuglist);
  813. end
  814. else if assigned(current_module.globalsymtable) then
  815. begin
  816. { all types }
  817. punitsymtable(current_module.globalsymtable)^.concattypestabto(debuglist);
  818. { and all local symbols}
  819. punitsymtable(current_module.globalsymtable)^.concatstabto(debuglist);
  820. end;
  821. end;
  822. {$Else GDB}
  823. begin
  824. end;
  825. {$EndIf GDB}
  826. procedure parse_implementation_uses(symt:Psymtable);
  827. begin
  828. if token=_USES then
  829. begin
  830. symt^.symtabletype:=unitsymtable;
  831. loadunits;
  832. symt^.symtabletype:=globalsymtable;
  833. {$ifdef DEBUG}
  834. test_symtablestack;
  835. {$endif DEBUG}
  836. end;
  837. end;
  838. procedure setupglobalswitches;
  839. begin
  840. { can't have local browser when no global browser }
  841. if (cs_local_browser in aktmoduleswitches) and
  842. not(cs_browser in aktmoduleswitches) then
  843. exclude(aktmoduleswitches,cs_local_browser);
  844. { define a symbol in delphi,objfpc,tp,gpc mode }
  845. if (m_delphi in aktmodeswitches) then
  846. current_scanner^.def_macro('FPC_DELPHI')
  847. else
  848. if (m_tp in aktmodeswitches) then
  849. current_scanner^.def_macro('FPC_TP')
  850. else
  851. if (m_objfpc in aktmodeswitches) then
  852. current_scanner^.def_macro('FPC_OBJFPC')
  853. else
  854. if (m_gpc in aktmodeswitches) then
  855. current_scanner^.def_macro('FPC_GPC');
  856. end;
  857. procedure gen_main_procsym(const name:string;options:tproctypeoption;st:psymtable);
  858. var
  859. stt : psymtable;
  860. begin
  861. {Generate a procsym for main}
  862. make_ref:=false;
  863. aktprocsym:=new(Pprocsym,init('$'+name));
  864. { main are allways used }
  865. inc(aktprocsym^.refs);
  866. {Try to insert in in static symtable ! }
  867. stt:=symtablestack;
  868. symtablestack:=st;
  869. aktprocsym^.definition:=new(Pprocdef,init);
  870. symtablestack:=stt;
  871. aktprocsym^.definition^.proctypeoption:=options;
  872. aktprocsym^.definition^.setmangledname(target_os.cprefix+name);
  873. aktprocsym^.definition^.forwarddef:=false;
  874. make_ref:=true;
  875. { The localst is a local symtable. Change it into the static
  876. symtable }
  877. dispose(aktprocsym^.definition^.localst,done);
  878. aktprocsym^.definition^.localst:=st;
  879. { and insert the procsym in symtable }
  880. st^.insert(aktprocsym);
  881. { set some informations about the main program }
  882. with procinfo^ do
  883. begin
  884. returntype.setdef(voiddef);
  885. _class:=nil;
  886. para_offset:=8;
  887. framepointer:=frame_pointer;
  888. flags:=0;
  889. end;
  890. end;
  891. procedure proc_unit;
  892. function is_assembler_generated:boolean;
  893. begin
  894. is_assembler_generated:=(Errorcount=0) and
  895. not(
  896. codeSegment.empty and
  897. dataSegment.empty and
  898. bssSegment.empty and
  899. ((importssection=nil) or importsSection.empty) and
  900. ((resourcesection=nil) or resourceSection.empty) and
  901. ((resourcestringlist=nil) or resourcestringList.empty)
  902. );
  903. end;
  904. var
  905. main_file: tinputfile;
  906. st : psymtable;
  907. unitst : punitsymtable;
  908. {$ifdef GDB}
  909. pu : tused_unit;
  910. {$endif GDB}
  911. store_crc,store_interface_crc : longint;
  912. s2 : ^string; {Saves stack space}
  913. force_init_final : boolean;
  914. begin
  915. consume(_UNIT);
  916. if token=_ID then
  917. begin
  918. { create filenames and unit name }
  919. main_file := current_scanner^.inputfile;
  920. while assigned(main_file.next) do
  921. main_file := main_file.next;
  922. current_module.SetFileName(main_file.path^+main_file.name^,true);
  923. stringdispose(current_module.modulename);
  924. stringdispose(current_module.realmodulename);
  925. current_module.modulename:=stringdup(pattern);
  926. current_module.realmodulename:=stringdup(orgpattern);
  927. { check for system unit }
  928. new(s2);
  929. s2^:=upper(SplitName(main_file.name^));
  930. if (cs_compilesystem in aktmoduleswitches) then
  931. begin
  932. if ((length(current_module.modulename^)>8) or
  933. (current_module.modulename^<>'SYSTEM') or
  934. (current_module.modulename^<>s2^)) then
  935. Message1(unit_e_illegal_unit_name,current_module.realmodulename^);
  936. end
  937. else
  938. begin
  939. if (cs_check_unit_name in aktglobalswitches) and
  940. not((current_module.modulename^=s2^) or
  941. ((length(current_module.modulename^)>8) and
  942. (copy(current_module.modulename^,1,8)=s2^))) then
  943. Message1(unit_e_illegal_unit_name,current_module.realmodulename^);
  944. if (current_module.modulename^='SYSTEM') then
  945. Message(unit_w_switch_us_missed);
  946. end;
  947. dispose(s2);
  948. end;
  949. consume(_ID);
  950. consume(_SEMICOLON);
  951. consume(_INTERFACE);
  952. { global switches are read, so further changes aren't allowed }
  953. current_module.in_global:=false;
  954. { handle the global switches }
  955. setupglobalswitches;
  956. Message1(unit_u_start_parse_interface,current_module.realmodulename^);
  957. { update status }
  958. status.currentmodule:=current_module.realmodulename^;
  959. { maybe turn off m_objpas if we are compiling objpas }
  960. if (current_module.modulename^='OBJPAS') then
  961. aktmodeswitches:=aktmodeswitches-[m_objpas];
  962. { this should be placed after uses !!}
  963. {$ifndef UseNiceNames}
  964. procprefix:='_'+current_module.modulename^+'$$';
  965. {$else UseNiceNames}
  966. procprefix:='_'+tostr(length(current_module.modulename^))+lowercase(current_module.modulename^)+'_';
  967. {$endif UseNiceNames}
  968. parse_only:=true;
  969. { generate now the global symboltable }
  970. st:=new(punitsymtable,init(globalsymtable,current_module.modulename^));
  971. refsymtable:=st;
  972. unitst:=punitsymtable(st);
  973. { define first as local to overcome dependency conflicts }
  974. current_module.localsymtable:=st;
  975. { the unit name must be usable as a unit specifier }
  976. { inside the unit itself (PM) }
  977. { this also forbids to have another symbol }
  978. { with the same name as the unit }
  979. refsymtable^.insert(new(punitsym,init(current_module.realmodulename^,unitst)));
  980. { a unit compiled at command line must be inside the loaded_unit list }
  981. if (compile_level=1) then
  982. loaded_units.insert(current_module);
  983. { load default units, like the system unit }
  984. loaddefaultunits;
  985. { reset }
  986. make_ref:=true;
  987. lexlevel:=0;
  988. { insert qualifier for the system unit (allows system.writeln) }
  989. if not(cs_compilesystem in aktmoduleswitches) then
  990. begin
  991. if token=_USES then
  992. begin
  993. unitst^.symtabletype:=unitsymtable;
  994. loadunits;
  995. { has it been compiled at a higher level ?}
  996. if current_module.compiled then
  997. begin
  998. { this unit symtable is obsolete }
  999. { dispose(unitst,done);
  1000. disposed as localsymtable !! }
  1001. RestoreUnitSyms;
  1002. exit;
  1003. end;
  1004. unitst^.symtabletype:=globalsymtable;
  1005. end;
  1006. { ... but insert the symbol table later }
  1007. st^.next:=symtablestack;
  1008. symtablestack:=st;
  1009. end
  1010. else
  1011. { while compiling a system unit, some types are directly inserted }
  1012. begin
  1013. st^.next:=symtablestack;
  1014. symtablestack:=st;
  1015. insert_intern_types(st);
  1016. end;
  1017. { now we know the place to insert the constants }
  1018. constsymtable:=symtablestack;
  1019. { move the global symtab from the temporary local to global }
  1020. current_module.globalsymtable:=current_module.localsymtable;
  1021. current_module.localsymtable:=nil;
  1022. reset_global_defs;
  1023. { number all units, so we know if a unit is used by this unit or
  1024. needs to be added implicitly }
  1025. numberunits;
  1026. { ... parse the declarations }
  1027. Message1(parser_u_parsing_interface,current_module.realmodulename^);
  1028. read_interface_declarations;
  1029. { leave when we got an error }
  1030. if (Errorcount>0) and not status.skip_error then
  1031. begin
  1032. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1033. status.skip_error:=true;
  1034. exit;
  1035. end;
  1036. {else in inteface its somatimes necessary even if unused
  1037. st^.allunitsused; }
  1038. {$ifdef New_GDB}
  1039. write_gdb_info;
  1040. {$endIf Def New_GDB}
  1041. if not(cs_compilesystem in aktmoduleswitches) then
  1042. if (Errorcount=0) then
  1043. writeunitas(current_module.ppufilename^,punitsymtable(symtablestack),true);
  1044. { Parse the implementation section }
  1045. consume(_IMPLEMENTATION);
  1046. current_module.in_implementation:=true;
  1047. Message1(unit_u_start_parse_implementation,current_module.modulename^);
  1048. parse_only:=false;
  1049. { generates static symbol table }
  1050. st:=new(punitsymtable,init(staticsymtable,current_module.modulename^));
  1051. current_module.localsymtable:=st;
  1052. { remove the globalsymtable from the symtable stack }
  1053. { to reinsert it after loading the implementation units }
  1054. symtablestack:=unitst^.next;
  1055. { we don't want implementation units symbols in unitsymtable !! PM }
  1056. refsymtable:=st;
  1057. { Read the implementation units }
  1058. parse_implementation_uses(unitst);
  1059. if current_module.compiled then
  1060. begin
  1061. RestoreUnitSyms;
  1062. exit;
  1063. end;
  1064. { reset ranges/stabs in exported definitions }
  1065. reset_global_defs;
  1066. { All units are read, now give them a number }
  1067. numberunits;
  1068. { now we can change refsymtable }
  1069. refsymtable:=st;
  1070. { but reinsert the global symtable as lasts }
  1071. unitst^.next:=symtablestack;
  1072. symtablestack:=unitst;
  1073. {$ifndef DONOTCHAINOPERATORS}
  1074. pstoredsymtable(symtablestack)^.chainoperators;
  1075. {$endif DONOTCHAINOPERATORS}
  1076. {$ifdef DEBUG}
  1077. test_symtablestack;
  1078. {$endif DEBUG}
  1079. constsymtable:=symtablestack;
  1080. {$ifdef Splitheap}
  1081. if testsplit then
  1082. begin
  1083. Split_Heap;
  1084. allow_special:=true;
  1085. Switch_to_temp_heap;
  1086. end;
  1087. { it will report all crossings }
  1088. allow_special:=false;
  1089. {$endif Splitheap}
  1090. Message1(parser_u_parsing_implementation,current_module.realmodulename^);
  1091. { Compile the unit }
  1092. codegen_newprocedure;
  1093. gen_main_procsym(current_module.modulename^+'_init',potype_unitinit,st);
  1094. aktprocsym^.definition^.aliasnames.insert('INIT$$'+current_module.modulename^);
  1095. aktprocsym^.definition^.aliasnames.insert(target_os.cprefix+current_module.modulename^+'_init');
  1096. compile_proc_body(true,false);
  1097. codegen_doneprocedure;
  1098. { avoid self recursive destructor call !! PM }
  1099. aktprocsym^.definition^.localst:=nil;
  1100. { if the unit contains ansi/widestrings, initialization and
  1101. finalization code must be forced }
  1102. force_init_final:=needs_init_final(current_module.globalsymtable)
  1103. or needs_init_final(current_module.localsymtable);
  1104. { should we force unit initialization? }
  1105. { this is a hack, but how can it be done better ? }
  1106. if force_init_final and ((current_module.flags and uf_init)=0) then
  1107. begin
  1108. current_module.flags:=current_module.flags or uf_init;
  1109. { now we can insert a cut }
  1110. if (cs_create_smart in aktmoduleswitches) then
  1111. codeSegment.concat(Tai_cut.Create);
  1112. genimplicitunitinit(codesegment);
  1113. end;
  1114. { finalize? }
  1115. if token=_FINALIZATION then
  1116. begin
  1117. { set module options }
  1118. current_module.flags:=current_module.flags or uf_finalize;
  1119. { Compile the finalize }
  1120. codegen_newprocedure;
  1121. gen_main_procsym(current_module.modulename^+'_finalize',potype_unitfinalize,st);
  1122. aktprocsym^.definition^.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
  1123. aktprocsym^.definition^.aliasnames.insert(target_os.cprefix+current_module.modulename^+'_finalize');
  1124. compile_proc_body(true,false);
  1125. codegen_doneprocedure;
  1126. end
  1127. else if force_init_final then
  1128. begin
  1129. current_module.flags:=current_module.flags or uf_finalize;
  1130. { now we can insert a cut }
  1131. if (cs_create_smart in aktmoduleswitches) then
  1132. codeSegment.concat(Tai_cut.Create);
  1133. genimplicitunitfinal(codesegment);
  1134. end;
  1135. { the last char should always be a point }
  1136. consume(_POINT);
  1137. If ResourceStrings.ResStrCount>0 then
  1138. begin
  1139. ResourceStrings.CreateResourceStringList;
  1140. current_module.flags:=current_module.flags or uf_has_resources;
  1141. { only write if no errors found }
  1142. if (Errorcount=0) then
  1143. ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
  1144. end;
  1145. { avoid self recursive destructor call !! PM }
  1146. aktprocsym^.definition^.localst:=nil;
  1147. { absence does not matter here !! }
  1148. aktprocsym^.definition^.forwarddef:=false;
  1149. { test static symtable }
  1150. if (Errorcount=0) then
  1151. begin
  1152. pstoredsymtable(st)^.allsymbolsused;
  1153. pstoredsymtable(st)^.allunitsused;
  1154. pstoredsymtable(st)^.allprivatesused;
  1155. end;
  1156. { size of the static data }
  1157. datasize:=st^.datasize;
  1158. {$ifdef GDB}
  1159. { add all used definitions even for implementation}
  1160. if (cs_debuginfo in aktmoduleswitches) then
  1161. begin
  1162. {$IfnDef New_GDB}
  1163. if assigned(current_module.globalsymtable) then
  1164. begin
  1165. { all types }
  1166. punitsymtable(current_module.globalsymtable)^.concattypestabto(debuglist);
  1167. { and all local symbols}
  1168. punitsymtable(current_module.globalsymtable)^.concatstabto(debuglist);
  1169. end;
  1170. { all local types }
  1171. punitsymtable(st)^.concattypestabto(debuglist);
  1172. { and all local symbols}
  1173. st^.concatstabto(debuglist);
  1174. {$else New_GDB}
  1175. write_gdb_info;
  1176. {$endIf Def New_GDB}
  1177. end;
  1178. {$endif GDB}
  1179. reset_global_defs;
  1180. { tests, if all (interface) forwards are resolved }
  1181. if (Errorcount=0) then
  1182. begin
  1183. pstoredsymtable(symtablestack)^.check_forwards;
  1184. pstoredsymtable(symtablestack)^.allprivatesused;
  1185. end;
  1186. { now we have a correct unit, change the symtable type }
  1187. current_module.in_implementation:=false;
  1188. symtablestack^.symtabletype:=unitsymtable;
  1189. {$ifdef GDB}
  1190. punitsymtable(symtablestack)^.is_stab_written:=false;
  1191. {$endif GDB}
  1192. { leave when we got an error }
  1193. if (Errorcount>0) and not status.skip_error then
  1194. begin
  1195. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1196. status.skip_error:=true;
  1197. closecurrentppu;
  1198. exit;
  1199. end;
  1200. { generate imports }
  1201. if current_module.uses_imports then
  1202. importlib.generatelib;
  1203. { insert own objectfile, or say that it's in a library
  1204. (no check for an .o when loading) }
  1205. if is_assembler_generated then
  1206. insertobjectfile
  1207. else
  1208. current_module.flags:=current_module.flags or uf_no_link;
  1209. if cs_local_browser in aktmoduleswitches then
  1210. current_module.localsymtable:=refsymtable;
  1211. { Write out the ppufile }
  1212. store_interface_crc:=current_module.interface_crc;
  1213. store_crc:=current_module.crc;
  1214. if (Errorcount=0) then
  1215. writeunitas(current_module.ppufilename^,punitsymtable(symtablestack),false);
  1216. if not(cs_compilesystem in aktmoduleswitches) then
  1217. if store_interface_crc<>current_module.interface_crc then
  1218. Comment(V_Warning,current_module.ppufilename^+' Interface CRC changed '+
  1219. tostr(store_crc)+'<>'+tostr(current_module.interface_crc));
  1220. {$ifdef EXTDEBUG}
  1221. if not(cs_compilesystem in aktmoduleswitches) then
  1222. if (store_crc<>current_module.crc) and simplify_ppu then
  1223. Comment(V_Warning,current_module.ppufilename^+' implementation CRC changed '+
  1224. tostr(store_crc)+'<>'+tostr(current_module.interface_crc));
  1225. {$endif EXTDEBUG}
  1226. { must be done only after local symtable ref stores !! }
  1227. closecurrentppu;
  1228. {$ifdef GDB}
  1229. pu:=tused_unit(usedunits.first);
  1230. while assigned(pu) do
  1231. begin
  1232. if assigned(pu.u.globalsymtable) then
  1233. punitsymtable(pu.u.globalsymtable)^.is_stab_written:=false;
  1234. pu:=tused_unit(pu.next);
  1235. end;
  1236. {$endif GDB}
  1237. { remove static symtable (=refsymtable) here to save some mem }
  1238. if not (cs_local_browser in aktmoduleswitches) then
  1239. begin
  1240. dispose(st,done);
  1241. current_module.localsymtable:=nil;
  1242. end;
  1243. RestoreUnitSyms;
  1244. if is_assembler_generated then
  1245. begin
  1246. { finish asmlist by adding segment starts }
  1247. insertsegment;
  1248. { assemble }
  1249. create_objectfile;
  1250. end;
  1251. { leave when we got an error }
  1252. if (Errorcount>0) and not status.skip_error then
  1253. begin
  1254. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1255. status.skip_error:=true;
  1256. exit;
  1257. end;
  1258. end;
  1259. procedure proc_program(islibrary : boolean);
  1260. var
  1261. main_file: tinputfile;
  1262. st : psymtable;
  1263. hp : tmodule;
  1264. begin
  1265. DLLsource:=islibrary;
  1266. IsExe:=true;
  1267. parse_only:=false;
  1268. { relocation works only without stabs under win32 !! PM }
  1269. { internal assembler uses rva for stabs info
  1270. so it should work with relocated DLLs }
  1271. if RelocSection and
  1272. (target_info.target=target_i386_win32) and
  1273. (target_info.assem<>as_i386_pecoff) then
  1274. begin
  1275. aktglobalswitches:=aktglobalswitches+[cs_link_strip];
  1276. { Warning stabs info does not work with reloc section !! }
  1277. if cs_debuginfo in aktmoduleswitches then
  1278. begin
  1279. Message1(parser_w_parser_reloc_no_debug,current_module.mainsource^);
  1280. Message(parser_w_parser_win32_debug_needs_WN);
  1281. aktmoduleswitches:=aktmoduleswitches-[cs_debuginfo];
  1282. end;
  1283. end;
  1284. { get correct output names }
  1285. main_file := current_scanner^.inputfile;
  1286. while assigned(main_file.next) do
  1287. main_file := main_file.next;
  1288. current_module.SetFileName(main_file.path^+main_file.name^,true);
  1289. if islibrary then
  1290. begin
  1291. consume(_LIBRARY);
  1292. stringdispose(current_module.modulename);
  1293. current_module.modulename:=stringdup(pattern);
  1294. current_module.islibrary:=true;
  1295. exportlib.preparelib(pattern);
  1296. consume(_ID);
  1297. consume(_SEMICOLON);
  1298. end
  1299. else
  1300. { is there an program head ? }
  1301. if token=_PROGRAM then
  1302. begin
  1303. consume(_PROGRAM);
  1304. stringdispose(current_module.modulename);
  1305. stringdispose(current_module.realmodulename);
  1306. current_module.modulename:=stringdup(pattern);
  1307. current_module.realmodulename:=stringdup(orgpattern);
  1308. if (target_info.target=target_i386_WIN32) then
  1309. exportlib.preparelib(pattern);
  1310. consume(_ID);
  1311. if token=_LKLAMMER then
  1312. begin
  1313. consume(_LKLAMMER);
  1314. idlist;
  1315. consume(_RKLAMMER);
  1316. end;
  1317. consume(_SEMICOLON);
  1318. end
  1319. else if (target_info.target=target_i386_WIN32) then
  1320. exportlib.preparelib(current_module.modulename^);
  1321. { global switches are read, so further changes aren't allowed }
  1322. current_module.in_global:=false;
  1323. { setup things using the global switches }
  1324. setupglobalswitches;
  1325. { set implementation flag }
  1326. current_module.in_implementation:=true;
  1327. { insert after the unit symbol tables the static symbol table }
  1328. { of the program }
  1329. st:=new(punitsymtable,init(staticsymtable,current_module.modulename^));
  1330. current_module.localsymtable:=st;
  1331. refsymtable:=st;
  1332. { load standard units (system,objpas,profile unit) }
  1333. loaddefaultunits;
  1334. { reset }
  1335. lexlevel:=0;
  1336. {Load the units used by the program we compile.}
  1337. if token=_USES then
  1338. loadunits;
  1339. { necessary for browser }
  1340. loaded_units.insert(current_module);
  1341. {$ifndef DONOTCHAINOPERATORS}
  1342. pstoredsymtable(symtablestack)^.chainoperators;
  1343. {$endif DONOTCHAINOPERATORS}
  1344. { reset ranges/stabs in exported definitions }
  1345. reset_global_defs;
  1346. { All units are read, now give them a number }
  1347. numberunits;
  1348. {Insert the name of the main program into the symbol table.}
  1349. if current_module.realmodulename^<>'' then
  1350. st^.insert(new(punitsym,init(current_module.realmodulename^,punitsymtable(st))));
  1351. { ...is also constsymtable, this is the symtable where }
  1352. { the elements of enumeration types are inserted }
  1353. constsymtable:=st;
  1354. Message1(parser_u_parsing_implementation,current_module.mainsource^);
  1355. { reset }
  1356. procprefix:='';
  1357. {The program intialization needs an alias, so it can be called
  1358. from the bootstrap code.}
  1359. codegen_newprocedure;
  1360. gen_main_procsym('main',potype_proginit,st);
  1361. aktprocsym^.definition^.aliasnames.insert('program_init');
  1362. aktprocsym^.definition^.aliasnames.insert('PASCALMAIN');
  1363. aktprocsym^.definition^.aliasnames.insert(target_os.cprefix+'main');
  1364. {$ifdef m68k}
  1365. if target_info.target=target_m68k_PalmOS then
  1366. aktprocsym^.definition^.aliasnames.insert('PilotMain');
  1367. {$endif m68k}
  1368. compile_proc_body(true,false);
  1369. { avoid self recursive destructor call !! PM }
  1370. aktprocsym^.definition^.localst:=nil;
  1371. { consider these symbols as global ones }
  1372. { for browser }
  1373. current_module.globalsymtable:=current_module.localsymtable;
  1374. current_module.localsymtable:=nil;
  1375. If ResourceStrings.ResStrCount>0 then
  1376. begin
  1377. ResourceStrings.CreateResourceStringList;
  1378. { only write if no errors found }
  1379. if (Errorcount=0) then
  1380. ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
  1381. end;
  1382. codegen_doneprocedure;
  1383. { finalize? }
  1384. if token=_FINALIZATION then
  1385. begin
  1386. { set module options }
  1387. current_module.flags:=current_module.flags or uf_finalize;
  1388. { Compile the finalize }
  1389. codegen_newprocedure;
  1390. gen_main_procsym(current_module.modulename^+'_finalize',potype_unitfinalize,st);
  1391. aktprocsym^.definition^.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
  1392. aktprocsym^.definition^.aliasnames.insert(target_os.cprefix+current_module.modulename^+'_finalize');
  1393. compile_proc_body(true,false);
  1394. codegen_doneprocedure;
  1395. end;
  1396. { consume the last point }
  1397. consume(_POINT);
  1398. {$ifdef New_GDB}
  1399. write_gdb_info;
  1400. {$endIf Def New_GDB}
  1401. { leave when we got an error }
  1402. if (Errorcount>0) and not status.skip_error then
  1403. begin
  1404. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1405. status.skip_error:=true;
  1406. exit;
  1407. end;
  1408. { test static symtable }
  1409. if (Errorcount=0) then
  1410. begin
  1411. pstoredsymtable(st)^.allsymbolsused;
  1412. pstoredsymtable(st)^.allunitsused;
  1413. pstoredsymtable(st)^.allprivatesused;
  1414. end;
  1415. { generate imports }
  1416. if current_module.uses_imports then
  1417. importlib.generatelib;
  1418. if islibrary or
  1419. (target_info.target=target_i386_WIN32) then
  1420. exportlib.generatelib;
  1421. { insert heap }
  1422. insertResourceTablesTable;
  1423. insertinitfinaltable;
  1424. insertheap;
  1425. inserttargetspecific;
  1426. datasize:=symtablestack^.datasize;
  1427. { finish asmlist by adding segment starts }
  1428. insertsegment;
  1429. { insert own objectfile }
  1430. insertobjectfile;
  1431. { assemble and link }
  1432. create_objectfile;
  1433. { leave when we got an error }
  1434. if (Errorcount>0) and not status.skip_error then
  1435. begin
  1436. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1437. status.skip_error:=true;
  1438. exit;
  1439. end;
  1440. { create the executable when we are at level 1 }
  1441. if (compile_level=1) then
  1442. begin
  1443. { insert all .o files from all loaded units }
  1444. hp:=tmodule(loaded_units.first);
  1445. while assigned(hp) do
  1446. begin
  1447. linker.AddModuleFiles(hp);
  1448. hp:=tmodule(hp.next);
  1449. end;
  1450. { write .def file }
  1451. if (cs_link_deffile in aktglobalswitches) then
  1452. deffile.writefile;
  1453. { finally we can create a executable }
  1454. if (not current_module.is_unit) then
  1455. begin
  1456. if DLLSource then
  1457. linker.MakeSharedLibrary
  1458. else
  1459. linker.MakeExecutable;
  1460. end;
  1461. end;
  1462. end;
  1463. end.
  1464. {
  1465. $Log$
  1466. Revision 1.23 2001-02-24 10:44:56 peter
  1467. * generate .rst from ppufilename instead of modulename
  1468. Revision 1.22 2001/02/21 19:37:19 peter
  1469. * moved deref to be done after loading of implementation units. prederef
  1470. is still done directly after loading of symbols and definitions.
  1471. Revision 1.21 2001/01/14 22:13:52 peter
  1472. * fixed crash with program name as a important unit name
  1473. Revision 1.20 2000/12/25 00:07:27 peter
  1474. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1475. tlinkedlist objects)
  1476. Revision 1.19 2000/11/29 00:30:36 florian
  1477. * unused units removed from uses clause
  1478. * some changes for widestrings
  1479. Revision 1.18 2000/11/01 23:04:37 peter
  1480. * tprocdef.fullprocname added for better casesensitve writing of
  1481. procedures
  1482. Revision 1.17 2000/10/31 22:02:50 peter
  1483. * symtable splitted, no real code changes
  1484. Revision 1.16 2000/10/21 14:36:26 peter
  1485. * merged pierres fixes
  1486. Revision 1.15 2000/10/15 09:08:58 peter
  1487. * use System for the systemunit instead of target dependent
  1488. Revision 1.14 2000/10/15 07:47:51 peter
  1489. * unit names and procedure names are stored mixed case
  1490. Revision 1.13 2000/10/04 14:51:08 pierre
  1491. * IsExe restored
  1492. Revision 1.12 2000/09/30 16:07:40 peter
  1493. * filepos when unit not found (merged)
  1494. Revision 1.11 2000/09/24 21:33:47 peter
  1495. * message updates merges
  1496. Revision 1.10 2000/09/24 15:06:22 peter
  1497. * use defines.inc
  1498. Revision 1.9 2000/08/31 07:53:02 michael
  1499. + Applied patch from Peter
  1500. Revision 1.8 2000/08/29 19:00:01 peter
  1501. * _init and _finalize procsyms also need a $ prefix
  1502. Revision 1.7 2000/08/27 20:19:39 peter
  1503. * store strings with case in ppu, when an internal symbol is created
  1504. a '$' is prefixed so it's not automatic uppercased
  1505. Revision 1.6 2000/08/27 16:11:52 peter
  1506. * moved some util functions from globals,cobjects to cutils
  1507. * splitted files into finput,fmodule
  1508. Revision 1.5 2000/08/25 08:48:22 jonas
  1509. * fixed bug with include files at the very beginning of .pp/.pas files
  1510. (wrong name used for generating exe/checking unit name) (merged from
  1511. fixes branch)
  1512. Revision 1.4 2000/08/21 11:27:44 pierre
  1513. * fix the stabs problems
  1514. Revision 1.3 2000/07/13 12:08:26 michael
  1515. + patched to 1.1.0 with former 1.09patch from peter
  1516. Revision 1.2 2000/07/13 11:32:45 michael
  1517. + removed logs
  1518. }