pmodules.pas 55 KB

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