pmodules.pas 57 KB

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