pmodules.pas 64 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862
  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. { define TEST_IMPL does not work well }
  20. { replaced by $define Double_checksum}
  21. { other way to get correct type info, in test (PM) }
  22. {$define New_GDB}
  23. interface
  24. procedure proc_unit;
  25. procedure proc_program(islibrary : boolean);
  26. implementation
  27. uses
  28. globtype,version,systems,tokens,
  29. cobjects,comphook,globals,verbose,files,
  30. symtable,aasm,hcodegen,
  31. link,assemble,import,export,gendef,ppu,comprsrc
  32. {$ifdef i386}
  33. {$ifdef Ag386Bin}
  34. ,i386base,i386asm
  35. {$else} ,i386
  36. {$endif}
  37. {$endif}
  38. {$ifdef m68k}
  39. ,m68k
  40. {$endif}
  41. ,scanner,pbase,psystem,pdecl,psub,parser;
  42. procedure create_objectfile;
  43. begin
  44. { create the .s file and assemble it }
  45. GenerateAsm;
  46. { resource files }
  47. CompileResourceFiles;
  48. { When creating a library call the linker. And insert the output
  49. of the linker files }
  50. if (cs_create_sharedlib in aktmoduleswitches) then
  51. Linker.MakeSharedLibrary
  52. else
  53. if (cs_create_staticlib in aktmoduleswitches)
  54. {$ifndef AG386BIN}
  55. or (cs_smartlink in aktmoduleswitches)
  56. {$endif}
  57. then
  58. Linker.MakeStaticLibrary(SmartLinkFilesCnt);
  59. end;
  60. procedure insertobjectfile;
  61. { Insert the used object file for this unit in the used list for this unit }
  62. begin
  63. if (cs_create_sharedlib in aktmoduleswitches) then
  64. begin
  65. current_module^.linksharedlibs.insert(current_module^.sharedlibfilename^);
  66. current_module^.flags:=current_module^.flags or uf_shared_linked;
  67. end
  68. else
  69. begin
  70. if (cs_create_staticlib in aktmoduleswitches) or
  71. (cs_smartlink in aktmoduleswitches) then
  72. begin
  73. current_module^.linkstaticlibs.insert(current_module^.staticlibfilename^);
  74. current_module^.flags:=current_module^.flags or uf_static_linked;
  75. end
  76. else
  77. begin
  78. current_module^.linkunitfiles.insert(current_module^.objfilename^);
  79. current_module^.flags:=current_module^.flags or uf_obj_linked;
  80. end;
  81. end;
  82. end;
  83. procedure insertsegment;
  84. procedure fixseg(p:paasmoutput;sec:tsection);
  85. begin
  86. p^.insert(new(pai_section,init(sec)));
  87. if (cs_smartlink in aktmoduleswitches) then
  88. p^.insert(new(pai_cut,init));
  89. p^.concat(new(pai_section,init(sec_none)));
  90. end;
  91. begin
  92. {Insert Ident of the compiler}
  93. if (not (cs_smartlink in aktmoduleswitches))
  94. {$ifndef EXTDEBUG}
  95. and (not current_module^.is_unit)
  96. {$endif}
  97. then
  98. begin
  99. datasegment^.insert(new(pai_align,init(4)));
  100. datasegment^.insert(new(pai_string,init('FPC '+version_string+
  101. ' for '+target_cpu_string+' - '+target_info.short_name)));
  102. end;
  103. { Insert start and end of sections }
  104. fixseg(codesegment,sec_code);
  105. fixseg(datasegment,sec_data);
  106. fixseg(bsssegment,sec_bss);
  107. { we should use .rdata section for these two no ? }
  108. { .rdata is a read only data section (PM) }
  109. fixseg(rttilist,sec_data);
  110. fixseg(consts,sec_data);
  111. {$ifdef GDB}
  112. if assigned(debuglist) then
  113. fixseg(debuglist,sec_code);
  114. {$endif GDB}
  115. end;
  116. procedure InsertInitFinalTable;
  117. var
  118. hp : pused_unit;
  119. unitinits : taasmoutput;
  120. count : longint;
  121. begin
  122. unitinits.init;
  123. count:=0;
  124. hp:=pused_unit(usedunits.first);
  125. while assigned(hp) do
  126. begin
  127. { call the unit init code and make it external }
  128. if (hp^.u^.flags and (uf_init or uf_finalize))<>0 then
  129. begin
  130. if (hp^.u^.flags and uf_init)<>0 then
  131. begin
  132. unitinits.concat(new(pai_const_symbol,init('INIT$$'+hp^.u^.modulename^)));
  133. concat_external('INIT$$'+hp^.u^.modulename^,EXT_NEAR);
  134. end
  135. else
  136. unitinits.concat(new(pai_const,init_32bit(0)));
  137. if (hp^.u^.flags and uf_finalize)<>0 then
  138. begin
  139. unitinits.concat(new(pai_const_symbol,init('FINALIZE$$'+hp^.u^.modulename^)));
  140. concat_external('FINALIZE$$'+hp^.u^.modulename^,EXT_NEAR);
  141. end
  142. else
  143. unitinits.concat(new(pai_const,init_32bit(0)));
  144. inc(count);
  145. end;
  146. hp:=Pused_unit(hp^.next);
  147. end;
  148. { TableCount,InitCount }
  149. unitinits.insert(new(pai_const,init_32bit(0)));
  150. unitinits.insert(new(pai_const,init_32bit(count)));
  151. unitinits.insert(new(pai_symbol,init_global('INITFINAL')));
  152. { insert in data segment }
  153. if (cs_smartlink in aktmoduleswitches) then
  154. datasegment^.concat(new(pai_cut,init));
  155. datasegment^.concatlist(@unitinits);
  156. unitinits.done;
  157. end;
  158. procedure insertheap;
  159. begin
  160. if (cs_smartlink in aktmoduleswitches) then
  161. begin
  162. bsssegment^.concat(new(pai_cut,init));
  163. datasegment^.concat(new(pai_cut,init));
  164. end;
  165. { On the Macintosh Classic M68k Architecture
  166. The Heap variable is simply a POINTER to the
  167. real HEAP. The HEAP must be set up by the RTL
  168. and must store the pointer in this value.
  169. On OS/2 the heap is also intialized by the RTL. We do
  170. not output a pointer }
  171. case target_info.target of
  172. {$ifdef i386}
  173. target_i386_OS2:
  174. ;
  175. {$endif i386}
  176. {$ifdef m68k}
  177. target_m68k_Mac:
  178. bsssegment^.concat(new(pai_datablock,init_global('HEAP',4)));
  179. target_m68k_PalmOS:
  180. ;
  181. {$endif m68k}
  182. else
  183. bsssegment^.concat(new(pai_datablock,init_global('HEAP',heapsize)));
  184. end;
  185. {$ifdef i386}
  186. datasegment^.concat(new(pai_symbol,init_global('HEAPSIZE')));
  187. datasegment^.concat(new(pai_const,init_32bit(heapsize)));
  188. {$endif i386}
  189. {$ifdef m68k}
  190. if target_info.target<>target_m68k_PalmOS then
  191. begin
  192. datasegment^.concat(new(pai_symbol,init_global('HEAP_SIZE')));
  193. datasegment^.concat(new(pai_const,init_32bit(heapsize)));
  194. end;
  195. {$endif m68k}
  196. end;
  197. procedure inserttargetspecific;
  198. begin
  199. case target_info.target of
  200. {$ifdef i386}
  201. target_i386_GO32V2 :
  202. begin
  203. { stacksize can be specified }
  204. datasegment^.concat(new(pai_symbol,init_global('__stklen')));
  205. datasegment^.concat(new(pai_const,init_32bit(stacksize)));
  206. end;
  207. target_i386_WIN32 :
  208. begin
  209. { Generate an external entry to be sure that _mainCRTStarup will be
  210. linked, can't use concat_external because those aren't written for
  211. asw (PFV) }
  212. target_link.bindcmd[1]:=target_link.bindcmd[1]+' -d '+deffile.fname;
  213. if DLLsource then
  214. target_link.binders:=2;
  215. if RelocSection then
  216. begin
  217. target_link.linkcmd:=target_link.linkcmd+' --base-file base.$$$';
  218. target_link.bindcmd[1]:=target_link.bindcmd[1]+' --base-file base.$$$';
  219. target_link.binders:=2;
  220. end;
  221. if apptype=at_gui then
  222. begin
  223. target_link.linkcmd:='--subsystem windows '+target_link.linkcmd;
  224. target_link.bindcmd[2]:='--subsystem windows '+target_link.bindcmd[2];
  225. end;
  226. if DLLsource then
  227. begin
  228. target_link.linkcmd:='--dll '+target_link.linkcmd;
  229. target_link.bindcmd[2]:='--dll '+target_link.bindcmd[2];
  230. end;
  231. end;
  232. {$endif i386}
  233. {$ifdef m68k}
  234. target_m68k_Atari :
  235. begin
  236. { stacksize can be specified }
  237. datasegment^.concat(new(pai_symbol,init_global('__stklen')));
  238. datasegment^.concat(new(pai_const,init_32bit(stacksize)));
  239. end;
  240. {$endif m68k}
  241. end;
  242. end;
  243. function loadunit(const s : string;compile_system:boolean) : pmodule;forward;
  244. procedure load_usedunits(compile_system:boolean);
  245. var
  246. pu : pused_unit;
  247. loaded_unit : pmodule;
  248. load_refs : boolean;
  249. nextmapentry : longint;
  250. begin
  251. load_refs:=true;
  252. { init the map }
  253. new(current_module^.map);
  254. fillchar(current_module^.map^,sizeof(tunitmap),#0);
  255. {$ifdef NEWMAP}
  256. current_module^.map^[0]:=current_module;
  257. {$endif NEWMAP}
  258. nextmapentry:=1;
  259. { load the used units from interface }
  260. current_module^.in_implementation:=false;
  261. pu:=pused_unit(current_module^.used_units.first);
  262. while assigned(pu) do
  263. begin
  264. if (not pu^.loaded) and (pu^.in_interface) then
  265. begin
  266. loaded_unit:=loadunit(pu^.name^,false);
  267. if current_module^.compiled then
  268. exit;
  269. { register unit in used units }
  270. pu^.u:=loaded_unit;
  271. pu^.loaded:=true;
  272. { doubles are not important for that list PM }
  273. pu^.u^.dependent_units.concat(new(pdependent_unit,init(current_module)));
  274. { need to recompile the current unit ? }
  275. if loaded_unit^.crc<>pu^.checksum then
  276. begin
  277. Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^);
  278. current_module^.do_compile:=true;
  279. {$ifdef STRANGERECOMPILE}
  280. { if the checksum was known but has changed then
  281. we should also recompile the loaded unit ! }
  282. if (pu^.checksum<>0) and (loaded_unit^.sources_avail) then
  283. begin
  284. Message2(unit_u_recompile_crc_change,loaded_unit^.modulename^,current_module^.modulename^);
  285. loaded_unit^.do_compile:=true;
  286. end;
  287. {$endif}
  288. dispose(current_module^.map);
  289. current_module^.map:=nil;
  290. exit;
  291. end;
  292. { setup the map entry for deref }
  293. {$ifndef NEWMAP}
  294. current_module^.map^[nextmapentry]:=loaded_unit^.globalsymtable;
  295. {$else NEWMAP}
  296. current_module^.map^[nextmapentry]:=loaded_unit;
  297. {$endif NEWMAP}
  298. inc(nextmapentry);
  299. if nextmapentry>maxunits then
  300. Message(unit_f_too_much_units);
  301. end;
  302. pu:=pused_unit(pu^.next);
  303. end;
  304. { ok, now load the unit }
  305. current_module^.globalsymtable:=new(punitsymtable,loadasunit);
  306. { if this is the system unit insert the intern symbols }
  307. {$ifndef STORENUMBER}
  308. if compile_system then
  309. begin
  310. make_ref:=false;
  311. insertinternsyms(psymtable(current_module^.globalsymtable));
  312. make_ref:=true;
  313. end;
  314. {$endif}
  315. { now only read the implementation part }
  316. current_module^.in_implementation:=true;
  317. { load the used units from implementation }
  318. pu:=pused_unit(current_module^.used_units.first);
  319. while assigned(pu) do
  320. begin
  321. if (not pu^.loaded) and (not pu^.in_interface) then
  322. begin
  323. loaded_unit:=loadunit(pu^.name^,false);
  324. if current_module^.compiled then
  325. exit;
  326. { register unit in used units }
  327. pu^.u:=loaded_unit;
  328. pu^.loaded:=true;
  329. {$ifdef Double_checksum}
  330. { need to recompile the current unit ? }
  331. if (loaded_unit^.interface_crc<>pu^.interface_checksum) then
  332. { checksum change whereas it was already known
  333. loade_unit was changed so we need to recompile this unit }
  334. begin
  335. {$ifdef STRANGERECOMPILE}
  336. {if (loaded_unit^.sources_avail) then
  337. begin
  338. loaded_unit^.do_compile:=true;
  339. end; }
  340. Message2(unit_u_recompile_crc_change,loaded_unit^.modulename^,current_module^.modulename^);
  341. loaded_unit^.do_compile:=true;
  342. if(pu^.interface_checksum<>0) then
  343. load_refs:=false;
  344. {$else}
  345. writeln('loaded intfc: ',loaded_unit^.interface_crc,' pu intfc ',pu^.interface_checksum);
  346. Message2(unit_u_recompile_crc_change,current_module^.modulename^,pu^.name^);
  347. current_module^.do_compile:=true;
  348. dispose(current_module^.map);
  349. current_module^.map:=nil;
  350. exit;
  351. {$endif}
  352. end;
  353. {$endif def Double_checksum}
  354. { setup the map entry for deref }
  355. {$ifndef NEWMAP}
  356. current_module^.map^[nextmapentry]:=loaded_unit^.globalsymtable;
  357. {$else NEWMAP}
  358. current_module^.map^[nextmapentry]:=loaded_unit;
  359. {$endif NEWMAP}
  360. inc(nextmapentry);
  361. if nextmapentry>maxunits then
  362. Message(unit_f_too_much_units);
  363. end;
  364. pu:=pused_unit(pu^.next);
  365. end;
  366. { load browser info if stored }
  367. if ((current_module^.flags and uf_has_browser)<>0) and load_refs then
  368. punitsymtable(current_module^.globalsymtable)^.load_symtable_refs;
  369. { remove the map, it's not needed anymore }
  370. dispose(current_module^.map);
  371. current_module^.map:=nil;
  372. end;
  373. function loadunit(const s : string;compile_system:boolean) : pmodule;
  374. const
  375. ImplIntf : array[boolean] of string[15]=('interface','implementation');
  376. var
  377. st : punitsymtable;
  378. second_time : boolean;
  379. old_current_ppu : pppufile;
  380. old_current_module,hp,hp2 : pmodule;
  381. name : string;{ necessary because
  382. current_module^.mainsource^ is reset in compile !! }
  383. scanner : pscannerfile;
  384. procedure loadppufile;
  385. begin
  386. { load interface section }
  387. if not current_module^.do_compile then
  388. load_interface;
  389. { only load units when we don't recompile }
  390. if not current_module^.do_compile then
  391. load_usedunits(compile_system);
  392. { recompile if set }
  393. if current_module^.do_compile then
  394. begin
  395. { we don't need the ppufile anymore }
  396. if assigned(current_module^.ppufile) then
  397. begin
  398. dispose(current_module^.ppufile,done);
  399. current_module^.ppufile:=nil;
  400. end;
  401. { recompile the unit or give a fatal error if sources not available }
  402. if not(current_module^.sources_avail) then
  403. if (not current_module^.search_unit(current_module^.modulename^,true))
  404. and (length(current_module^.modulename^)>8) then
  405. current_module^.search_unit(copy(current_module^.modulename^,1,8),true);
  406. if not(current_module^.sources_avail) then
  407. Message1(unit_f_cant_compile_unit,current_module^.modulename^)
  408. else
  409. begin
  410. if current_module^.in_second_compile then
  411. Message1(parser_d_compiling_second_time,current_module^.modulename^);
  412. current_scanner^.tempcloseinputfile;
  413. name:=current_module^.mainsource^;
  414. if assigned(scanner) then
  415. scanner^.invalid:=true;
  416. compile(name,compile_system);
  417. if (not current_scanner^.invalid) then
  418. current_scanner^.tempopeninputfile;
  419. end;
  420. end
  421. else
  422. begin
  423. { only reassemble ? }
  424. if (current_module^.do_assemble) then
  425. OnlyAsm;
  426. { add the files for the linker }
  427. Linker.AddModuleFiles(current_module);
  428. end;
  429. if assigned(current_module^.ppufile) then
  430. begin
  431. dispose(current_module^.ppufile,done);
  432. current_module^.ppufile:=nil;
  433. end;
  434. end;
  435. begin
  436. old_current_module:=current_module;
  437. old_current_ppu:=current_ppu;
  438. { Info }
  439. Message3(unit_u_load_unit,current_module^.modulename^,ImplIntf[current_module^.in_implementation],s);
  440. { unit not found }
  441. st:=nil;
  442. { search all loaded units }
  443. hp:=pmodule(loaded_units.first);
  444. while assigned(hp) do
  445. begin
  446. if hp^.modulename^=s then
  447. begin
  448. { the unit is already registered }
  449. { and this means that the unit }
  450. { is already compiled }
  451. { else there is a cyclic unit use }
  452. if assigned(hp^.globalsymtable) then
  453. st:=punitsymtable(hp^.globalsymtable)
  454. else
  455. begin
  456. { both units in interface ? }
  457. if (not current_module^.in_implementation) and (not hp^.in_implementation) then
  458. begin
  459. { check for a cycle }
  460. hp2:=current_module^.loaded_from;
  461. while assigned(hp2) and (hp2<>hp) do
  462. begin
  463. if hp2^.in_implementation then
  464. hp2:=nil
  465. else
  466. hp2:=hp2^.loaded_from;
  467. end;
  468. if assigned(hp2) then
  469. Message2(unit_f_circular_unit_reference,current_module^.modulename^,hp^.modulename^);
  470. end;
  471. end;
  472. break;
  473. end
  474. {$ifdef Double_checksum}
  475. else if hp^.do_reload_ppu then
  476. begin
  477. { remove the old unit }
  478. loaded_units.remove(hp);
  479. scanner:=hp^.scanner;
  480. name:=hp^.modulename^;
  481. hp^.reset;
  482. hp^.do_reload_ppu:=false;
  483. hp^.scanner:=scanner;
  484. { try to reopen ppu }
  485. hp^.search_unit(name,false);
  486. { try to load the unit a second time first }
  487. current_module:=hp;
  488. current_module^.in_second_compile:=true;
  489. { now realy load the ppu }
  490. current_ppu:=current_module^.ppufile;
  491. loadppufile;
  492. { set compiled flag }
  493. current_module^.compiled:=true;
  494. end;
  495. {$else Double_Checksum}
  496. ;
  497. {$endif Double_checksum}
  498. { the next unit }
  499. hp:=pmodule(hp^.next);
  500. end;
  501. { the unit is not in the symtable stack }
  502. if (not assigned(st))
  503. {$ifdef Double_checksum}
  504. or (assigned(hp) and hp^.do_reload_ppu)
  505. {$endif Double_checksum}
  506. then
  507. begin
  508. if assigned(hp) then
  509. begin
  510. { remove the old unit }
  511. loaded_units.remove(hp);
  512. scanner:=hp^.scanner;
  513. hp^.reset;
  514. {$ifdef Double_checksum}
  515. hp^.do_reload_ppu:=false;
  516. {$endif Double_checksum}
  517. hp^.scanner:=scanner;
  518. { try to reopen ppu }
  519. hp^.search_unit(s,false);
  520. { try to load the unit a second time first }
  521. current_module:=hp;
  522. current_module^.in_second_compile:=true;
  523. Message1(unit_u_second_load_unit,current_module^.modulename^);
  524. second_time:=true;
  525. end
  526. else
  527. { generates a new unit info record }
  528. begin
  529. current_module:=new(pmodule,init(s,true));
  530. scanner:=nil;
  531. second_time:=false;
  532. end;
  533. current_ppu:=current_module^.ppufile;
  534. { now we can register the unit }
  535. current_module^.loaded_from:=old_current_module;
  536. loaded_units.insert(current_module);
  537. { now realy load the ppu }
  538. loadppufile;
  539. { set compiled flag }
  540. current_module^.compiled:=true;
  541. { register the unit _once_ }
  542. { this is buggy PM }
  543. if not second_time then
  544. usedunits.concat(new(pused_unit,init(current_module,true)));
  545. { load return pointer }
  546. hp:=current_module;
  547. end;
  548. { set the old module }
  549. current_ppu:=old_current_ppu;
  550. current_module:=old_current_module;
  551. loadunit:=hp;
  552. end;
  553. procedure loaddefaultunits;
  554. var
  555. hp : pmodule;
  556. begin
  557. { are we compiling the system unit? }
  558. if (cs_compilesystem in aktmoduleswitches) then
  559. begin
  560. { create system defines }
  561. createconstdefs;
  562. { we don't need to reset anything, it's already done in parser.pas }
  563. exit;
  564. end;
  565. { insert the system unit, it is allways the first }
  566. hp:=loadunit(upper(target_info.system_unit),true);
  567. systemunit:=hp^.globalsymtable;
  568. { it's always the first unit }
  569. systemunit^.next:=nil;
  570. symtablestack:=systemunit;
  571. { add to the used units }
  572. current_module^.used_units.concat(new(pused_unit,init(hp,true)));
  573. refsymtable^.insert(new(punitsym,init('SYSTEM',systemunit)));
  574. { read default constant definitions }
  575. make_ref:=false;
  576. readconstdefs;
  577. make_ref:=true;
  578. { if POWER is defined in the RTL then use it for starstar overloading }
  579. getsym('POWER',false);
  580. if assigned(srsym) and (srsym^.typ=procsym) and (overloaded_operators[STARSTAR]=nil) then
  581. overloaded_operators[STARSTAR]:=pprocsym(srsym);
  582. { Objpas unit? }
  583. if m_objpas in aktmodeswitches then
  584. begin
  585. hp:=loadunit('OBJPAS',false);
  586. objpasunit:=hp^.globalsymtable;
  587. { insert in stack }
  588. objpasunit^.next:=symtablestack;
  589. symtablestack:=objpasunit;
  590. { add to the used units }
  591. current_module^.used_units.concat(new(pused_unit,init(hp,true)));
  592. refsymtable^.insert(new(punitsym,init('OBJPAS',objpasunit)));
  593. end
  594. else
  595. objpasunit:=nil;
  596. { Profile unit? Needed for go32v2 only }
  597. if (cs_profile in aktmoduleswitches) and (target_info.target=target_i386_go32v2) then
  598. begin
  599. hp:=loadunit('PROFILE',false);
  600. psymtable(hp^.globalsymtable)^.next:=symtablestack;
  601. symtablestack:=hp^.globalsymtable;
  602. { add to the used units }
  603. current_module^.used_units.concat(new(pused_unit,init(hp,true)));
  604. refsymtable^.insert(new(punitsym,init('PROFILE',hp^.globalsymtable)));
  605. end;
  606. { Heaptrc unit? (not needed for units), this is here to be sure that it is really
  607. loaded as first unit }
  608. if (cs_gdb_heaptrc in aktglobalswitches) and not(current_module^.is_unit)then
  609. begin
  610. hp:=loadunit('HEAPTRC',false);
  611. psymtable(hp^.globalsymtable)^.next:=symtablestack;
  612. symtablestack:=hp^.globalsymtable;
  613. { add to the used units }
  614. current_module^.used_units.concat(new(pused_unit,init(hp,true)));
  615. refsymtable^.insert(new(punitsym,init('HEAPTRC',hp^.globalsymtable)));
  616. end;
  617. { save default symtablestack }
  618. defaultsymtablestack:=symtablestack;
  619. end;
  620. procedure loadunits;
  621. var
  622. s : stringid;
  623. pu,
  624. hp : pused_unit;
  625. hp2 : pmodule;
  626. hp3 : psymtable;
  627. oldprocsym:Pprocsym;
  628. begin
  629. oldprocsym:=aktprocsym;
  630. consume(_USES);
  631. {$ifdef DEBUG}
  632. test_symtablestack;
  633. {$endif DEBUG}
  634. repeat
  635. s:=pattern;
  636. consume(ID);
  637. { check if the unit is already used }
  638. pu:=pused_unit(current_module^.used_units.first);
  639. while assigned(pu) do
  640. begin
  641. if (pu^.name^=s) then
  642. break;
  643. pu:=pused_unit(pu^.next);
  644. end;
  645. { avoid uses of itself }
  646. if not assigned(pu) and (s<>current_module^.modulename^) then
  647. begin
  648. { load the unit }
  649. hp2:=loadunit(s,false);
  650. { the current module uses the unit hp2 }
  651. current_module^.used_units.concat(new(pused_unit,init(hp2,not current_module^.in_implementation)));
  652. pused_unit(current_module^.used_units.last)^.in_uses:=true;
  653. if current_module^.compiled then
  654. exit;
  655. refsymtable^.insert(new(punitsym,init(s,hp2^.globalsymtable)));
  656. end
  657. else
  658. Message1(sym_e_duplicate_id,s);
  659. if token=COMMA then
  660. begin
  661. pattern:='';
  662. consume(COMMA);
  663. end
  664. else
  665. break;
  666. until false;
  667. consume(SEMICOLON);
  668. { set the symtable to systemunit so it gets reorderd correctly }
  669. symtablestack:=defaultsymtablestack;
  670. { now insert the units in the symtablestack }
  671. hp:=pused_unit(current_module^.used_units.first);
  672. while assigned(hp) do
  673. begin
  674. {$IfDef GDB}
  675. {$IfnDef New_GDB}
  676. if (cs_debuginfo in aktmoduleswitches) and
  677. not hp^.is_stab_written then
  678. begin
  679. punitsymtable(hp^.u^.globalsymtable)^.concattypestabto(debuglist);
  680. hp^.is_stab_written:=true;
  681. hp^.unitid:=psymtable(hp^.u^.globalsymtable)^.unitid;
  682. end;
  683. {$endIf nDef New_GDB}
  684. {$EndIf GDB}
  685. if hp^.in_uses then
  686. begin
  687. hp3:=symtablestack;
  688. while assigned(hp3) do
  689. begin
  690. { insert units only once ! }
  691. if hp^.u^.globalsymtable=hp3 then
  692. break;
  693. hp3:=hp3^.next;
  694. { unit isn't inserted }
  695. if hp3=nil then
  696. begin
  697. psymtable(hp^.u^.globalsymtable)^.next:=symtablestack;
  698. symtablestack:=psymtable(hp^.u^.globalsymtable);
  699. {$ifdef CHAINPROCSYMS}
  700. symtablestack^.chainprocsyms;
  701. {$endif CHAINPROCSYMS}
  702. {$ifdef DEBUG}
  703. test_symtablestack;
  704. {$endif DEBUG}
  705. end;
  706. end;
  707. end;
  708. hp:=pused_unit(hp^.next);
  709. end;
  710. aktprocsym:=oldprocsym;
  711. end;
  712. procedure write_gdb_info;
  713. {$IfDef GDB}
  714. var
  715. hp : pused_unit;
  716. begin
  717. if not (cs_debuginfo in aktmoduleswitches) then
  718. exit;
  719. { now insert the units in the symtablestack }
  720. hp:=pused_unit(current_module^.used_units.first);
  721. while assigned(hp) do
  722. begin
  723. if (cs_debuginfo in aktmoduleswitches) and
  724. not hp^.is_stab_written then
  725. begin
  726. punitsymtable(hp^.u^.globalsymtable)^.concattypestabto(debuglist);
  727. hp^.is_stab_written:=true;
  728. hp^.unitid:=psymtable(hp^.u^.globalsymtable)^.unitid;
  729. end;
  730. hp:=pused_unit(hp^.next);
  731. end;
  732. if current_module^.in_implementation then
  733. begin
  734. if assigned(current_module^.localsymtable) then
  735. begin
  736. { all types }
  737. punitsymtable(current_module^.localsymtable)^.concattypestabto(debuglist);
  738. { and all local symbols}
  739. punitsymtable(current_module^.localsymtable)^.concatstabto(debuglist);
  740. end;
  741. end
  742. else
  743. begin
  744. if assigned(current_module^.globalsymtable) then
  745. begin
  746. { all types }
  747. punitsymtable(current_module^.globalsymtable)^.concattypestabto(debuglist);
  748. { and all local symbols}
  749. punitsymtable(current_module^.globalsymtable)^.concatstabto(debuglist);
  750. end;
  751. end;
  752. end;
  753. {$Else GDB}
  754. begin
  755. end;
  756. {$EndIf GDB}
  757. procedure parse_implementation_uses(symt:Psymtable);
  758. begin
  759. if token=_USES then
  760. begin
  761. symt^.symtabletype:=unitsymtable;
  762. loadunits;
  763. symt^.symtabletype:=globalsymtable;
  764. {$ifdef DEBUG}
  765. test_symtablestack;
  766. {$endif DEBUG}
  767. end;
  768. end;
  769. procedure gen_main_procsym(const name:string;options:longint;st:psymtable);
  770. {$ifdef Double_checksum}
  771. var
  772. stt : psymtable;
  773. {$endif Double_checksum}
  774. begin
  775. {Generate a procsym for main}
  776. make_ref:=false;
  777. aktprocsym:=new(Pprocsym,init(name));
  778. {$ifdef Double_checksum}
  779. {Try to insert in in static symtable ! }
  780. stt:=symtablestack;
  781. symtablestack:=st;
  782. {$endif Double_checksum}
  783. aktprocsym^.definition:=new(Pprocdef,init);
  784. {$ifdef Double_checksum}
  785. symtablestack:=stt;
  786. {$endif Double_checksum}
  787. aktprocsym^.definition^.options:=aktprocsym^.definition^.options or options;
  788. aktprocsym^.definition^.setmangledname(target_os.cprefix+name);
  789. aktprocsym^.definition^.forwarddef:=false;
  790. make_ref:=true;
  791. { The localst is a local symtable. Change it into the static
  792. symtable }
  793. dispose(aktprocsym^.definition^.localst,done);
  794. aktprocsym^.definition^.localst:=st;
  795. { and insert the procsym in symtable }
  796. st^.insert(aktprocsym);
  797. { set some informations about the main program }
  798. with procinfo do
  799. begin
  800. retdef:=voiddef;
  801. _class:=nil;
  802. call_offset:=8;
  803. framepointer:=frame_pointer;
  804. flags:=0;
  805. end;
  806. end;
  807. procedure proc_unit;
  808. function is_assembler_generated:boolean;
  809. begin
  810. is_assembler_generated:=(Errorcount=0) and
  811. not(
  812. codesegment^.empty and
  813. datasegment^.empty and
  814. bsssegment^.empty and
  815. ((importssection=nil) or importssection^.empty) and
  816. ((resourcesection=nil) or resourcesection^.empty)
  817. );
  818. end;
  819. var
  820. names : Tstringcontainer;
  821. st : psymtable;
  822. unitst : punitsymtable;
  823. {$ifdef GDB}
  824. pu : pused_unit;
  825. {$endif GDB}
  826. {$ifdef Double_checksum}
  827. store_crc : longint;
  828. {$endif def Double_checksum}
  829. s1,s2 : ^string; {Saves stack space}
  830. begin
  831. consume(_UNIT);
  832. if token=ID then
  833. begin
  834. { create filenames and unit name }
  835. current_module^.SetFileName(current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^,true);
  836. stringdispose(current_module^.modulename);
  837. current_module^.modulename:=stringdup(upper(pattern));
  838. { check for system unit }
  839. new(s1);
  840. new(s2);
  841. s1^:=upper(target_info.system_unit);
  842. s2^:=upper(SplitName(current_scanner^.inputfile^.name^));
  843. if (cs_compilesystem in aktmoduleswitches) then
  844. begin
  845. if ((length(current_module^.modulename^)>8) or
  846. (current_module^.modulename^<>s1^) or
  847. (current_module^.modulename^<>s2^)) then
  848. Message1(unit_e_illegal_unit_name,current_module^.modulename^);
  849. end
  850. else
  851. begin
  852. if (cs_check_unit_name in aktglobalswitches) and
  853. not((current_module^.modulename^=s2^) or
  854. ((length(current_module^.modulename^)>8) and
  855. (copy(current_module^.modulename^,1,8)=s2^))) then
  856. Message1(unit_e_illegal_unit_name,current_module^.modulename^);
  857. if (current_module^.modulename^=s1^) then
  858. Message(unit_w_switch_us_missed);
  859. end;
  860. dispose(s2);
  861. dispose(s1);
  862. end;
  863. consume(ID);
  864. consume(SEMICOLON);
  865. consume(_INTERFACE);
  866. { global switches are read, so further changes aren't allowed }
  867. current_module^.in_global:=false;
  868. { can't have local browser when no global browser }
  869. if (cs_local_browser in aktmoduleswitches) and
  870. not(cs_browser in aktmoduleswitches) then
  871. aktmoduleswitches:=aktmoduleswitches-[cs_local_browser];
  872. Message1(unit_u_start_parse_interface,current_module^.modulename^);
  873. { update status }
  874. status.currentmodule:=current_module^.modulename^;
  875. { maybe turn off m_objpas if we are compiling objpas }
  876. if (current_module^.modulename^='OBJPAS') then
  877. aktmodeswitches:=aktmodeswitches-[m_objpas];
  878. { this should be placed after uses !!}
  879. {$ifndef UseNiceNames}
  880. procprefix:='_'+current_module^.modulename^+'$$';
  881. {$else UseNiceNames}
  882. procprefix:='_'+tostr(length(current_module^.modulename^))+lowercase(current_module^.modulename^)+'_';
  883. {$endif UseNiceNames}
  884. parse_only:=true;
  885. { generate now the global symboltable }
  886. st:=new(punitsymtable,init(globalsymtable,current_module^.modulename^));
  887. refsymtable:=st;
  888. unitst:=punitsymtable(st);
  889. { define first as local to overcome dependency conflicts }
  890. current_module^.localsymtable:=st;
  891. { the unit name must be usable as a unit specifier }
  892. { inside the unit itself (PM) }
  893. { this also forbids to have another symbol }
  894. { with the same name as the unit }
  895. refsymtable^.insert(new(punitsym,init(current_module^.modulename^,unitst)));
  896. { a unit compiled at command line must be inside the loaded_unit list }
  897. if (compile_level=1) then
  898. loaded_units.insert(current_module);
  899. { load default units, like the system unit }
  900. loaddefaultunits;
  901. { reset }
  902. make_ref:=true;
  903. lexlevel:=0;
  904. { insert qualifier for the system unit (allows system.writeln) }
  905. if not(cs_compilesystem in aktmoduleswitches) then
  906. begin
  907. if token=_USES then
  908. begin
  909. unitst^.symtabletype:=unitsymtable;
  910. loadunits;
  911. { has it been compiled at a higher level ?}
  912. if current_module^.compiled then
  913. begin
  914. { this unit symtable is obsolete }
  915. { dispose(unitst,done);
  916. disposed as localsymtable !! }
  917. exit;
  918. end;
  919. unitst^.symtabletype:=globalsymtable;
  920. end;
  921. { ... but insert the symbol table later }
  922. st^.next:=symtablestack;
  923. symtablestack:=st;
  924. end
  925. else
  926. { while compiling a system unit, some types are directly inserted }
  927. begin
  928. st^.next:=symtablestack;
  929. symtablestack:=st;
  930. insert_intern_types(st);
  931. end;
  932. { now we know the place to insert the constants }
  933. constsymtable:=symtablestack;
  934. { move the global symtab from the temporary local to global }
  935. current_module^.globalsymtable:=current_module^.localsymtable;
  936. current_module^.localsymtable:=nil;
  937. reset_global_defs;
  938. { ... parse the declarations }
  939. read_interface_declarations;
  940. { leave when we got an error }
  941. if (Errorcount>0) and not status.skip_error then
  942. begin
  943. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  944. status.skip_error:=true;
  945. exit;
  946. end;
  947. {$ifdef New_GDB}
  948. write_gdb_info;
  949. {$endIf Def New_GDB}
  950. {$ifdef Double_CheckSum}
  951. {$ifdef Test_Double_checksum}
  952. if (Errorcount=0) then
  953. writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack),true);
  954. {$endif Test_Double_checksum}
  955. {$endif Double_CheckSum}
  956. { Parse the implementation section }
  957. consume(_IMPLEMENTATION);
  958. current_module^.in_implementation:=true;
  959. Message1(unit_u_start_parse_implementation,current_module^.modulename^);
  960. parse_only:=false;
  961. { generates static symbol table }
  962. st:=new(punitsymtable,init(staticsymtable,current_module^.modulename^));
  963. current_module^.localsymtable:=st;
  964. { remove the globalsymtable from the symtable stack }
  965. { to reinsert it after loading the implementation units }
  966. symtablestack:=unitst^.next;
  967. {$ifndef STORENUMBER}
  968. { number the definitions, so a deref from other units works }
  969. refsymtable^.number_defs;
  970. refsymtable^.number_symbols;
  971. {$endif}
  972. { we don't want implementation units symbols in unitsymtable !! PM }
  973. refsymtable:=st;
  974. { Read the implementation units }
  975. parse_implementation_uses(unitst);
  976. if current_module^.compiled then
  977. begin
  978. exit;
  979. end;
  980. { reset ranges/stabs in exported definitions }
  981. { If I find who removed this line !!!!!!!
  982. I AM TIRED OF THIS !!!!!!!!!!!
  983. DONT TOUCH WITHOUT ASKING ME Pierre Muller }
  984. reset_global_defs;
  985. { All units are read, now give them a number }
  986. numberunits;
  987. { now we can change refsymtable }
  988. refsymtable:=st;
  989. { but reinsert the global symtable as lasts }
  990. unitst^.next:=symtablestack;
  991. symtablestack:=unitst;
  992. {$ifdef DEBUG}
  993. test_symtablestack;
  994. {$endif DEBUG}
  995. constsymtable:=symtablestack;
  996. {$ifdef Splitheap}
  997. if testsplit then
  998. begin
  999. Split_Heap;
  1000. allow_special:=true;
  1001. Switch_to_temp_heap;
  1002. end;
  1003. { it will report all crossings }
  1004. allow_special:=false;
  1005. {$endif Splitheap}
  1006. { Generate a procsym }
  1007. gen_main_procsym(current_module^.modulename^+'_init',pounitinit,st);
  1008. { Compile the unit }
  1009. codegen_newprocedure;
  1010. names.init;
  1011. names.insert('INIT$$'+current_module^.modulename^);
  1012. names.insert(target_os.cprefix+current_module^.modulename^+'_init');
  1013. compile_proc_body(names,true,false);
  1014. names.done;
  1015. codegen_doneprocedure;
  1016. { avoid self recursive destructor call !! PM }
  1017. aktprocsym^.definition^.localst:=nil;
  1018. { finalize? }
  1019. if token=_FINALIZATION then
  1020. begin
  1021. { set module options }
  1022. current_module^.flags:=current_module^.flags or uf_finalize;
  1023. { Generate a procsym }
  1024. gen_main_procsym(current_module^.modulename^+'_finalize',pounitfinalize,st);
  1025. { Compile the finalize }
  1026. codegen_newprocedure;
  1027. names.init;
  1028. names.insert('FINALIZE$$'+current_module^.modulename^);
  1029. names.insert(target_os.cprefix+current_module^.modulename^+'_finalize');
  1030. compile_proc_body(names,true,false);
  1031. names.done;
  1032. codegen_doneprocedure;
  1033. { avoid self recursive destructor call !! PM }
  1034. aktprocsym^.definition^.localst:=nil;
  1035. end;
  1036. { the last char should always be a point }
  1037. consume(POINT);
  1038. { avoid self recursive destructor call !! PM }
  1039. aktprocsym^.definition^.localst:=nil;
  1040. { absence does not matter here !! }
  1041. aktprocsym^.definition^.forwarddef:=false;
  1042. { test static symtable }
  1043. if (Errorcount=0) then
  1044. st^.allsymbolsused;
  1045. { size of the static data }
  1046. datasize:=st^.datasize;
  1047. {$ifdef GDB}
  1048. { add all used definitions even for implementation}
  1049. if (cs_debuginfo in aktmoduleswitches) then
  1050. begin
  1051. {$IfnDef New_GDB}
  1052. if assigned(current_module^.globalsymtable) then
  1053. begin
  1054. { all types }
  1055. punitsymtable(current_module^.globalsymtable)^.concattypestabto(debuglist);
  1056. { and all local symbols}
  1057. punitsymtable(current_module^.globalsymtable)^.concatstabto(debuglist);
  1058. end;
  1059. { all local types }
  1060. punitsymtable(st)^.concattypestabto(debuglist);
  1061. { and all local symbols}
  1062. st^.concatstabto(debuglist);
  1063. {$else New_GDB}
  1064. write_gdb_info;
  1065. {$endIf Def New_GDB}
  1066. end;
  1067. {$endif GDB}
  1068. reset_global_defs;
  1069. { tests, if all (interface) forwards are resolved }
  1070. if (Errorcount=0) then
  1071. symtablestack^.check_forwards;
  1072. { now we have a correct unit, change the symtable type }
  1073. current_module^.in_implementation:=false;
  1074. symtablestack^.symtabletype:=unitsymtable;
  1075. {$ifdef GDB}
  1076. punitsymtable(symtablestack)^.is_stab_written:=false;
  1077. {$endif GDB}
  1078. { leave when we got an error }
  1079. if (Errorcount>0) and not status.skip_error then
  1080. begin
  1081. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1082. status.skip_error:=true;
  1083. exit;
  1084. end;
  1085. { generate imports }
  1086. if current_module^.uses_imports then
  1087. importlib^.generatelib;
  1088. { insert own objectfile, or say that it's in a library
  1089. (no check for an .o when loading) }
  1090. if is_assembler_generated then
  1091. insertobjectfile;
  1092. if cs_local_browser in aktmoduleswitches then
  1093. current_module^.localsymtable:=refsymtable;
  1094. { Write out the ppufile }
  1095. {$ifdef Double_checksum}
  1096. store_crc:=current_module^.interface_crc;
  1097. {$endif def Double_checksum}
  1098. if (Errorcount=0) then
  1099. writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack),false);
  1100. {$ifdef Double_checksum}
  1101. {$ifdef Test_Double_checksum}
  1102. if store_crc<>current_module^.interface_crc then
  1103. Def_comment(V_Warning,current_module^.ppufilename^+' CRC changed '+
  1104. tostr(store_crc)+'<>'+tostr(current_module^.interface_crc));
  1105. {$endif def TestDouble_checksum}
  1106. {$endif def Double_checksum}
  1107. { must be done only after local symtable ref stores !! }
  1108. closecurrentppu;
  1109. {$ifdef GDB}
  1110. pu:=pused_unit(usedunits.first);
  1111. while assigned(pu) do
  1112. begin
  1113. punitsymtable(pu^.u^.globalsymtable)^.is_stab_written:=false;
  1114. pu:=pused_unit(pu^.next);
  1115. end;
  1116. {$endif GDB}
  1117. { remove static symtable (=refsymtable) here to save some mem }
  1118. if not (cs_local_browser in aktmoduleswitches) then
  1119. begin
  1120. dispose(st,done);
  1121. current_module^.localsymtable:=nil;
  1122. end;
  1123. if is_assembler_generated then
  1124. begin
  1125. { finish asmlist by adding segment starts }
  1126. insertsegment;
  1127. { assemble }
  1128. create_objectfile;
  1129. end;
  1130. { add the files for the linker from current_module }
  1131. Linker.AddModuleFiles(current_module);
  1132. end;
  1133. procedure proc_program(islibrary : boolean);
  1134. var
  1135. st : psymtable;
  1136. names : Tstringcontainer;
  1137. begin
  1138. DLLsource:=islibrary;
  1139. parse_only:=false;
  1140. if islibrary then
  1141. begin
  1142. consume(_LIBRARY);
  1143. stringdispose(current_module^.modulename);
  1144. current_module^.modulename:=stringdup(pattern);
  1145. current_module^.islibrary:=true;
  1146. exportlib^.preparelib(pattern);
  1147. consume(ID);
  1148. consume(SEMICOLON);
  1149. end
  1150. else
  1151. { is there an program head ? }
  1152. if token=_PROGRAM then
  1153. begin
  1154. consume(_PROGRAM);
  1155. stringdispose(current_module^.modulename);
  1156. current_module^.modulename:=stringdup(pattern);
  1157. consume(ID);
  1158. if token=LKLAMMER then
  1159. begin
  1160. consume(LKLAMMER);
  1161. idlist;
  1162. consume(RKLAMMER);
  1163. end;
  1164. consume(SEMICOLON);
  1165. end;
  1166. { global switches are read, so further changes aren't allowed }
  1167. current_module^.in_global:=false;
  1168. { can't have local browser when no global browser }
  1169. if (cs_local_browser in aktmoduleswitches) and
  1170. not(cs_browser in aktmoduleswitches) then
  1171. aktmoduleswitches:=aktmoduleswitches-[cs_local_browser];
  1172. { set implementation flag }
  1173. current_module^.in_implementation:=true;
  1174. { insert after the unit symbol tables the static symbol table }
  1175. { of the program }
  1176. st:=new(punitsymtable,init(staticsymtable,current_module^.modulename^));
  1177. current_module^.localsymtable:=st;
  1178. symtablestack:=st;
  1179. refsymtable:=st;
  1180. { necessary for browser }
  1181. loaded_units.insert(current_module);
  1182. { load standard units (system,objpas,profile unit) }
  1183. loaddefaultunits;
  1184. { reset }
  1185. lexlevel:=0;
  1186. {Load the units used by the program we compile.}
  1187. if token=_USES then
  1188. loadunits;
  1189. reset_global_defs;
  1190. {Insert the name of the main program into the symbol table.}
  1191. if current_module^.modulename^<>'' then
  1192. {st^.insert(new(pprogramsym,init(current_module^.modulename^)));}
  1193. st^.insert(new(punitsym,init(current_module^.modulename^,punitsymtable(st))));
  1194. { ...is also constsymtable, this is the symtable where }
  1195. { the elements of enumeration types are inserted }
  1196. constsymtable:=st;
  1197. { Generate a procsym for main }
  1198. gen_main_procsym('main',poproginit,st);
  1199. { reset }
  1200. procprefix:='';
  1201. in_except_block:=false;
  1202. {The program intialization needs an alias, so it can be called
  1203. from the bootstrap code.}
  1204. codegen_newprocedure;
  1205. names.init;
  1206. names.insert('program_init');
  1207. names.insert('PASCALMAIN');
  1208. names.insert(target_os.cprefix+'main');
  1209. {$ifdef m68k}
  1210. if target_info.target=target_m68k_PalmOS then
  1211. names.insert('PilotMain');
  1212. {$endif}
  1213. compile_proc_body(names,true,false);
  1214. names.done;
  1215. { avoid self recursive destructor call !! PM }
  1216. aktprocsym^.definition^.localst:=nil;
  1217. { consider these symbols as global ones }
  1218. { for browser }
  1219. current_module^.globalsymtable:=current_module^.localsymtable;
  1220. current_module^.localsymtable:=nil;
  1221. codegen_doneprocedure;
  1222. { consume the last point }
  1223. consume(POINT);
  1224. {$ifdef New_GDB}
  1225. write_gdb_info;
  1226. {$endIf Def New_GDB}
  1227. { leave when we got an error }
  1228. if (Errorcount>0) and not status.skip_error then
  1229. begin
  1230. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1231. status.skip_error:=true;
  1232. exit;
  1233. end;
  1234. { generate imports }
  1235. if current_module^.uses_imports then
  1236. importlib^.generatelib;
  1237. if islibrary then
  1238. exportlib^.generatelib;
  1239. { insert heap }
  1240. insertinitfinaltable;
  1241. insertheap;
  1242. inserttargetspecific;
  1243. datasize:=symtablestack^.datasize;
  1244. { finish asmlist by adding segment starts }
  1245. insertsegment;
  1246. { insert own objectfile }
  1247. insertobjectfile;
  1248. { assemble and link }
  1249. create_objectfile;
  1250. { add the files for the linker from current_module }
  1251. Linker.AddModuleFiles(current_module);
  1252. { create the executable when we are at level 1 }
  1253. if (compile_level=1) then
  1254. begin
  1255. if (cs_link_deffile in aktglobalswitches) then
  1256. deffile.writefile;
  1257. if (not current_module^.is_unit) then
  1258. Linker.MakeExecutable;
  1259. end;
  1260. end;
  1261. end.
  1262. {
  1263. $Log$
  1264. Revision 1.112 1999-04-25 15:08:38 peter
  1265. * small fixes for double_checksum
  1266. Revision 1.111 1999/04/21 09:43:46 peter
  1267. * storenumber works
  1268. * fixed some typos in double_checksum
  1269. + incompatible types type1 and type2 message (with storenumber)
  1270. Revision 1.110 1999/04/17 13:14:52 peter
  1271. * concat_external added for new init/final
  1272. Revision 1.109 1999/04/15 12:19:59 peter
  1273. + finalization support
  1274. Revision 1.108 1999/04/14 09:14:52 peter
  1275. * first things to store the symbol/def number in the ppu
  1276. Revision 1.107 1999/04/08 10:53:54 michael
  1277. * Fixed forgotten ;
  1278. Revision 1.106 1999/04/07 15:39:30 pierre
  1279. + double_checksum code added
  1280. Revision 1.105 1999/03/26 00:05:38 peter
  1281. * released valintern
  1282. + deffile is now removed when compiling is finished
  1283. * ^( compiles now correct
  1284. + static directive
  1285. * shrd fixed
  1286. Revision 1.104 1999/03/24 23:17:17 peter
  1287. * fixed bugs 212,222,225,227,229,231,233
  1288. Revision 1.103 1999/03/18 20:30:46 peter
  1289. + .a writer
  1290. Revision 1.102 1999/03/16 21:07:25 peter
  1291. * check for dup uses
  1292. Revision 1.101 1999/02/25 21:02:43 peter
  1293. * ag386bin updates
  1294. + coff writer
  1295. Revision 1.100 1999/02/23 18:29:20 pierre
  1296. * win32 compilation error fix
  1297. + some work for local browser (not cl=omplete yet)
  1298. Revision 1.99 1999/02/22 13:06:58 pierre
  1299. + -b and -bl options work !
  1300. + cs_local_browser ($L+) is disabled if cs_browser ($Y+)
  1301. is not enabled when quitting global section
  1302. * local vars and procedures are not yet stored into PPU
  1303. Revision 1.98 1999/02/22 02:15:29 peter
  1304. * updates for ag386bin
  1305. Revision 1.97 1999/02/16 00:45:31 peter
  1306. * fixed crashes by forgotten strpnew() for init_symbol
  1307. Revision 1.96 1999/02/05 08:54:27 pierre
  1308. + linkofiles splitted inot linkofiles and linkunitfiles
  1309. because linkofiles must be stored with directory
  1310. to enabled linking of different objects with same name
  1311. in a different directory
  1312. Revision 1.95 1999/02/03 09:44:36 pierre
  1313. * symbol nubering begins with 1 in number_symbols
  1314. * program tmodule has globalsymtable for its staticsymtable
  1315. (to get it displayed in IDE globals list)
  1316. + list of symbol (browcol) greatly improved for IDE
  1317. Revision 1.94 1999/01/12 14:25:31 peter
  1318. + BrowserLog for browser.log generation
  1319. + BrowserCol for browser info in TCollections
  1320. * released all other UseBrowser
  1321. Revision 1.93 1999/01/06 12:39:46 peter
  1322. * renamed resource -> comprsrc (conflicted with FV)
  1323. Revision 1.92 1998/12/28 23:26:23 peter
  1324. + resource file handling ($R directive) for Win32
  1325. Revision 1.91 1998/12/15 17:14:17 peter
  1326. * fix for tp7
  1327. Revision 1.90 1998/12/15 10:23:26 peter
  1328. + -iSO, -iSP, -iTO, -iTP
  1329. Revision 1.89 1998/12/11 00:03:34 peter
  1330. + globtype,tokens,version unit splitted from globals
  1331. Revision 1.88 1998/12/08 10:18:11 peter
  1332. + -gh for heaptrc unit
  1333. Revision 1.87 1998/12/01 23:40:53 pierre
  1334. * new try for correct debug info generation
  1335. Revision 1.86 1998/11/30 09:43:22 pierre
  1336. * some range check bugs fixed (still not working !)
  1337. + added DLL writing support for win32 (also accepts variables)
  1338. + TempAnsi for code that could be used for Temporary ansi strings
  1339. handling
  1340. Revision 1.85 1998/11/28 16:20:54 peter
  1341. + support for dll variables
  1342. Revision 1.84 1998/11/18 09:18:03 pierre
  1343. + automatic loading of profile unit with -pg option
  1344. in go32v2 mode (also defines FPC_PROFILE)
  1345. * some memory leaks removed
  1346. * unreleased temp problem with sets solved
  1347. Revision 1.83 1998/11/16 11:29:00 pierre
  1348. * stackcheck removed for i386_win32
  1349. * exportlist does not crash at least !!
  1350. (was need for tests dir !)z
  1351. Revision 1.82 1998/11/12 12:55:16 pierre
  1352. * fix for bug0176 and bug0177
  1353. Revision 1.81 1998/11/12 11:34:58 peter
  1354. * fix for empty .o files and linking of libs
  1355. Revision 1.80 1998/11/06 09:48:14 pierre
  1356. * double initialization code calling bug fixed
  1357. Revision 1.79 1998/11/03 11:33:11 peter
  1358. + search_unit arg to only search for sources
  1359. Revision 1.78 1998/10/30 12:23:41 peter
  1360. * fix for lognunitname and longunit.pas
  1361. Revision 1.77 1998/10/29 11:35:52 florian
  1362. * some dll support for win32
  1363. * fixed assembler writing for PalmOS
  1364. Revision 1.76 1998/10/28 18:26:15 pierre
  1365. * removed some erros after other errors (introduced by useexcept)
  1366. * stabs works again correctly (for how long !)
  1367. Revision 1.75 1998/10/27 13:45:35 pierre
  1368. * classes get a vmt allways
  1369. * better error info (tried to remove
  1370. several error strings introduced by the tpexcept handling)
  1371. Revision 1.74 1998/10/26 09:34:50 peter
  1372. * unit check name works now for all units, not only systemunit
  1373. Revision 1.73 1998/10/22 23:53:27 peter
  1374. * leave when an error has been in the interface (else other units could
  1375. be compiled with the implementation uses!)
  1376. * don't always compile when not in implementation with a second_load
  1377. Revision 1.72 1998/10/22 11:36:34 peter
  1378. * fixed imports generation at the wrong place
  1379. Revision 1.71 1998/10/21 20:13:10 peter
  1380. * check for importsection for empty asm file
  1381. Revision 1.70 1998/10/20 09:30:05 peter
  1382. * set also in_library flag when no .o is generated
  1383. Revision 1.68 1998/10/19 08:54:59 pierre
  1384. * wrong stabs info corrected once again !!
  1385. + variable vmt offset with vmt field only if required
  1386. implemented now !!!
  1387. Revision 1.67 1998/10/13 13:10:25 peter
  1388. * new style for m68k/i386 infos and enums
  1389. Revision 1.66 1998/10/09 16:36:05 pierre
  1390. * some memory leaks specific to usebrowser define fixed
  1391. * removed tmodule.implsymtable (was like tmodule.localsymtable)
  1392. Revision 1.65 1998/10/09 14:38:55 pierre
  1393. * add a second load for PPU file
  1394. Revision 1.64 1998/10/09 08:56:28 pierre
  1395. * several memory leaks fixed
  1396. Revision 1.63 1998/10/08 23:29:01 peter
  1397. * -vu shows unit info, -vt shows tried/used files
  1398. Revision 1.62 1998/10/08 17:17:25 pierre
  1399. * current_module old scanner tagged as invalid if unit is recompiled
  1400. + added ppheap for better info on tracegetmem of heaptrc
  1401. (adds line column and file index)
  1402. * several memory leaks removed ith help of heaptrc !!
  1403. Revision 1.61 1998/10/08 13:48:47 peter
  1404. * fixed memory leaks for do nothing source
  1405. * fixed unit interdependency
  1406. Revision 1.60 1998/10/06 17:16:54 pierre
  1407. * some memory leaks fixed (thanks to Peter for heaptrc !)
  1408. Revision 1.59 1998/10/05 21:33:26 peter
  1409. * fixed 161,165,166,167,168
  1410. Revision 1.58 1998/09/30 16:43:37 peter
  1411. * fixed unit interdependency with circular uses
  1412. Revision 1.57 1998/09/30 12:11:52 peter
  1413. * fixed circular uses which looped forever
  1414. Revision 1.56 1998/09/28 11:22:15 pierre
  1415. * did not compile for browser
  1416. * merge from fixes
  1417. Revision 1.48.2.1 1998/09/28 10:55:16 pierre
  1418. fix for current_module dispose bug
  1419. Revision 1.55 1998/09/28 11:04:03 peter
  1420. * fixed loaddefaultunits which was at the wrong place for programs, so
  1421. the default defs were not loaded when main was initialized
  1422. Revision 1.54 1998/09/24 23:49:12 peter
  1423. + aktmodeswitches
  1424. Revision 1.53 1998/09/23 12:20:50 pierre
  1425. * main program tmodule had no symtable (crashed browser)
  1426. * unit symbols problem fixed !!
  1427. Revision 1.52 1998/09/22 17:13:49 pierre
  1428. + browsing updated and developed
  1429. records and objects fields are also stored
  1430. Revision 1.51 1998/09/22 15:40:55 peter
  1431. * some extra ifdef GDB
  1432. Revision 1.50 1998/09/21 08:45:17 pierre
  1433. + added vmt_offset in tobjectdef.write for fututre use
  1434. (first steps to have objects without vmt if no virtual !!)
  1435. + added fpu_used field for tabstractprocdef :
  1436. sets this level to 2 if the functions return with value in FPU
  1437. (is then set to correct value at parsing of implementation)
  1438. THIS MIGHT refuse some code with FPU expression too complex
  1439. that were accepted before and even in some cases
  1440. that don't overflow in fact
  1441. ( like if f : float; is a forward that finally in implementation
  1442. only uses one fpu register !!)
  1443. Nevertheless I think that it will improve security on
  1444. FPU operations !!
  1445. * most other changes only for UseBrowser code
  1446. (added symtable references for record and objects)
  1447. local switch for refs to args and local of each function
  1448. (static symtable still missing)
  1449. UseBrowser still not stable and probably broken by
  1450. the definition hash array !!
  1451. Revision 1.49 1998/09/18 08:01:36 pierre
  1452. + improvement on the usebrowser part
  1453. (does not work correctly for now)
  1454. Revision 1.48 1998/09/09 15:33:07 peter
  1455. * fixed in_global to allow directives also after interface token
  1456. Revision 1.47 1998/09/09 11:50:55 pierre
  1457. * forward def are not put in record or objects
  1458. + added check for forwards also in record and objects
  1459. * dummy parasymtable for unit initialization removed from
  1460. symtable stack
  1461. Revision 1.46 1998/09/03 11:24:01 peter
  1462. * moved more inputfile things from tscannerfile to tinputfile
  1463. * changed ifdef Sourceline to cs_asm_source
  1464. Revision 1.45 1998/08/31 12:26:28 peter
  1465. * m68k and palmos updates from surebugfixes
  1466. Revision 1.44 1998/08/26 15:35:33 peter
  1467. * fixed scannerfiles for macros
  1468. + $I %<environment>%
  1469. Revision 1.43 1998/08/26 10:08:47 peter
  1470. * fixed problem with libprefix at the wrong place
  1471. * fixed lib generation with smartlinking and no -CS used
  1472. Revision 1.42 1998/08/19 18:04:54 peter
  1473. * fixed current_module^.in_implementation flag
  1474. Revision 1.41 1998/08/17 10:10:08 peter
  1475. - removed OLDPPU
  1476. Revision 1.40 1998/08/17 09:17:50 peter
  1477. * static/shared linking updates
  1478. Revision 1.39 1998/08/14 21:56:37 peter
  1479. * setting the outputfile using -o works now to create static libs
  1480. Revision 1.38 1998/08/10 14:50:13 peter
  1481. + localswitches, moduleswitches, globalswitches splitting
  1482. Revision 1.37 1998/08/10 10:18:31 peter
  1483. + Compiler,Comphook unit which are the new interface units to the
  1484. compiler
  1485. Revision 1.36 1998/07/14 14:46:54 peter
  1486. * released NEWINPUT
  1487. Revision 1.35 1998/07/08 12:39:38 peter
  1488. * heap_size for m68k
  1489. Revision 1.34 1998/07/07 11:20:03 peter
  1490. + NEWINPUT for a better inputfile and scanner object
  1491. Revision 1.33 1998/06/25 11:15:34 pierre
  1492. * ppu files where not closed in newppu !!
  1493. second compilation was impossible due to too many opened files
  1494. (not visible in 'make cycle' as we remove all the ppu files)
  1495. Revision 1.32 1998/06/25 08:48:16 florian
  1496. * first version of rtti support
  1497. Revision 1.31 1998/06/24 14:48:35 peter
  1498. * ifdef newppu -> ifndef oldppu
  1499. Revision 1.30 1998/06/17 14:10:16 peter
  1500. * small os2 fixes
  1501. * fixed interdependent units with newppu (remake3 under linux works now)
  1502. Revision 1.29 1998/06/16 08:56:25 peter
  1503. + targetcpu
  1504. * cleaner pmodules for newppu
  1505. Revision 1.28 1998/06/13 00:10:10 peter
  1506. * working browser and newppu
  1507. * some small fixes against crashes which occured in bp7 (but not in
  1508. fpc?!)
  1509. Revision 1.27 1998/06/11 13:58:08 peter
  1510. * small fix to let newppu compile
  1511. Revision 1.26 1998/06/09 16:01:47 pierre
  1512. + added procedure directive parsing for procvars
  1513. (accepted are popstack cdecl and pascal)
  1514. + added C vars with the following syntax
  1515. var C calias 'true_c_name';(can be followed by external)
  1516. reason is that you must add the Cprefix
  1517. which is target dependent
  1518. Revision 1.25 1998/06/08 22:59:49 peter
  1519. * smartlinking works for win32
  1520. * some defines to exclude some compiler parts
  1521. Revision 1.24 1998/06/08 13:13:44 pierre
  1522. + temporary variables now in temp_gen.pas unit
  1523. because it is processor independent
  1524. * mppc68k.bat modified to undefine i386 and support_mmx
  1525. (which are defaults for i386)
  1526. Revision 1.23 1998/06/05 17:47:29 peter
  1527. * some better uses clauses
  1528. Revision 1.22 1998/06/05 14:37:34 pierre
  1529. * fixes for inline for operators
  1530. * inline procedure more correctly restricted
  1531. Revision 1.21 1998/06/04 23:51:53 peter
  1532. * m68k compiles
  1533. + .def file creation moved to gendef.pas so it could also be used
  1534. for win32
  1535. Revision 1.20 1998/06/04 09:55:42 pierre
  1536. * demangled name of procsym reworked to become independant of the mangling scheme
  1537. Revision 1.19 1998/06/03 23:40:38 peter
  1538. + unlimited file support, release tempclose
  1539. Revision 1.18 1998/06/03 22:49:00 peter
  1540. + wordbool,longbool
  1541. * rename bis,von -> high,low
  1542. * moved some systemunit loading/creating to psystem.pas
  1543. Revision 1.17 1998/05/28 14:40:25 peter
  1544. * fixes for newppu, remake3 works now with it
  1545. Revision 1.16 1998/05/27 19:45:06 peter
  1546. * symtable.pas splitted into includefiles
  1547. * symtable adapted for $ifdef NEWPPU
  1548. Revision 1.15 1998/05/23 01:21:22 peter
  1549. + aktasmmode, aktoptprocessor, aktoutputformat
  1550. + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
  1551. + $LIBNAME to set the library name where the unit will be put in
  1552. * splitted cgi386 a bit (codeseg to large for bp7)
  1553. * nasm, tasm works again. nasm moved to ag386nsm.pas
  1554. Revision 1.14 1998/05/20 09:42:35 pierre
  1555. + UseTokenInfo now default
  1556. * unit in interface uses and implementation uses gives error now
  1557. * only one error for unknown symbol (uses lastsymknown boolean)
  1558. the problem came from the label code !
  1559. + first inlined procedures and function work
  1560. (warning there might be allowed cases were the result is still wrong !!)
  1561. * UseBrower updated gives a global list of all position of all used symbols
  1562. with switch -gb
  1563. Revision 1.13 1998/05/12 10:47:00 peter
  1564. * moved printstatus to verb_def
  1565. + V_Normal which is between V_Error and V_Warning and doesn't have a
  1566. prefix like error: warning: and is included in V_Default
  1567. * fixed some messages
  1568. * first time parameter scan is only for -v and -T
  1569. - removed old style messages
  1570. Revision 1.12 1998/05/11 13:07:56 peter
  1571. + $ifdef NEWPPU for the new ppuformat
  1572. + $define GDB not longer required
  1573. * removed all warnings and stripped some log comments
  1574. * no findfirst/findnext anymore to remove smartlink *.o files
  1575. Revision 1.11 1998/05/06 18:36:53 peter
  1576. * tai_section extended with code,data,bss sections and enumerated type
  1577. * ident 'compiled by FPC' moved to pmodules
  1578. * small fix for smartlink
  1579. Revision 1.10 1998/05/04 17:54:28 peter
  1580. + smartlinking works (only case jumptable left todo)
  1581. * redesign of systems.pas to support assemblers and linkers
  1582. + Unitname is now also in the PPU-file, increased version to 14
  1583. Revision 1.9 1998/05/01 16:38:45 florian
  1584. * handling of private and protected fixed
  1585. + change_keywords_to_tp implemented to remove
  1586. keywords which aren't supported by tp
  1587. * break and continue are now symbols of the system unit
  1588. + widestring, longstring and ansistring type released
  1589. Revision 1.8 1998/04/30 15:59:41 pierre
  1590. * GDB works again better :
  1591. correct type info in one pass
  1592. + UseTokenInfo for better source position
  1593. * fixed one remaining bug in scanner for line counts
  1594. * several little fixes
  1595. Revision 1.7 1998/04/29 10:33:59 pierre
  1596. + added some code for ansistring (not complete nor working yet)
  1597. * corrected operator overloading
  1598. * corrected nasm output
  1599. + started inline procedures
  1600. + added starstarn : use ** for exponentiation (^ gave problems)
  1601. + started UseTokenInfo cond to get accurate positions
  1602. Revision 1.6 1998/04/27 23:10:28 peter
  1603. + new scanner
  1604. * $makelib -> if smartlink
  1605. * small filename fixes pmodule.setfilename
  1606. * moved import from files.pas -> import.pas
  1607. Revision 1.5 1998/04/14 23:27:03 florian
  1608. + exclude/include with constant second parameter added
  1609. Revision 1.4 1998/04/10 14:41:43 peter
  1610. * removed some Hints
  1611. * small speed optimization for AsmLn
  1612. Revision 1.3 1998/04/03 09:51:00 daniel
  1613. * Fixed heap allocation for OS/2.
  1614. }