pmodules.pas 58 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. Handles the parsing and loading of the modules (ppufiles)
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit pmodules;
  19. { 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. returntype.setdef(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 under win32 !! PM }
  1215. { internal assembler uses rva for stabs info
  1216. so it should work with relocated DLLs }
  1217. if RelocSection and
  1218. (target_info.target=target_i386_win32) and
  1219. (target_info.assem<>as_i386_pecoff) then
  1220. begin
  1221. aktglobalswitches:=aktglobalswitches+[cs_link_strip];
  1222. { Warning stabs info does not work with reloc section !! }
  1223. if cs_debuginfo in aktmoduleswitches then
  1224. begin
  1225. Message1(parser_w_parser_reloc_no_debug,current_module^.mainsource^);
  1226. Message(parser_w_parser_win32_debug_needs_WN);
  1227. aktmoduleswitches:=aktmoduleswitches-[cs_debuginfo];
  1228. end;
  1229. end;
  1230. if islibrary then
  1231. begin
  1232. consume(_LIBRARY);
  1233. stringdispose(current_module^.modulename);
  1234. current_module^.modulename:=stringdup(pattern);
  1235. current_module^.islibrary:=true;
  1236. exportlib^.preparelib(pattern);
  1237. consume(_ID);
  1238. consume(_SEMICOLON);
  1239. end
  1240. else
  1241. { is there an program head ? }
  1242. if token=_PROGRAM then
  1243. begin
  1244. consume(_PROGRAM);
  1245. stringdispose(current_module^.modulename);
  1246. current_module^.modulename:=stringdup(pattern);
  1247. if (target_info.target=target_i386_WIN32) then
  1248. exportlib^.preparelib(pattern);
  1249. consume(_ID);
  1250. if token=_LKLAMMER then
  1251. begin
  1252. consume(_LKLAMMER);
  1253. idlist;
  1254. consume(_RKLAMMER);
  1255. end;
  1256. consume(_SEMICOLON);
  1257. end
  1258. else if (target_info.target=target_i386_WIN32) then
  1259. exportlib^.preparelib(current_module^.modulename^);
  1260. { global switches are read, so further changes aren't allowed }
  1261. current_module^.in_global:=false;
  1262. { get correct output names }
  1263. current_module^.SetFileName(current_scanner^.inputfile^.path^+current_scanner^.inputfile^.name^,true);
  1264. { setup things using the global switches }
  1265. setupglobalswitches;
  1266. { set implementation flag }
  1267. current_module^.in_implementation:=true;
  1268. { insert after the unit symbol tables the static symbol table }
  1269. { of the program }
  1270. st:=new(punitsymtable,init(staticsymtable,current_module^.modulename^));
  1271. current_module^.localsymtable:=st;
  1272. symtablestack:=st;
  1273. refsymtable:=st;
  1274. { necessary for browser }
  1275. loaded_units.insert(current_module);
  1276. { load standard units (system,objpas,profile unit) }
  1277. loaddefaultunits;
  1278. { reset }
  1279. lexlevel:=0;
  1280. {Load the units used by the program we compile.}
  1281. if token=_USES then
  1282. loadunits;
  1283. { reset ranges/stabs in exported definitions }
  1284. reset_global_defs;
  1285. { All units are read, now give them a number }
  1286. numberunits;
  1287. {Insert the name of the main program into the symbol table.}
  1288. if current_module^.modulename^<>'' then
  1289. {st^.insert(new(pprogramsym,init(current_module^.modulename^)));}
  1290. st^.insert(new(punitsym,init(current_module^.modulename^,punitsymtable(st))));
  1291. { ...is also constsymtable, this is the symtable where }
  1292. { the elements of enumeration types are inserted }
  1293. constsymtable:=st;
  1294. Message1(parser_u_parsing_implementation,current_module^.mainsource^);
  1295. { reset }
  1296. procprefix:='';
  1297. {The program intialization needs an alias, so it can be called
  1298. from the bootstrap code.}
  1299. codegen_newprocedure;
  1300. gen_main_procsym('main',potype_proginit,st);
  1301. names.init;
  1302. names.insert('program_init');
  1303. names.insert('PASCALMAIN');
  1304. names.insert(target_os.cprefix+'main');
  1305. {$ifdef m68k}
  1306. if target_info.target=target_m68k_PalmOS then
  1307. names.insert('PilotMain');
  1308. {$endif}
  1309. compile_proc_body(names,true,false);
  1310. names.done;
  1311. { avoid self recursive destructor call !! PM }
  1312. aktprocsym^.definition^.localst:=nil;
  1313. { consider these symbols as global ones }
  1314. { for browser }
  1315. current_module^.globalsymtable:=current_module^.localsymtable;
  1316. current_module^.localsymtable:=nil;
  1317. If ResourceStringList<>Nil then
  1318. begin
  1319. insertresourcestrings;
  1320. WriteResourceFile(Current_module^.ModuleName^);
  1321. end;
  1322. codegen_doneprocedure;
  1323. { finalize? }
  1324. if token=_FINALIZATION then
  1325. begin
  1326. { set module options }
  1327. current_module^.flags:=current_module^.flags or uf_finalize;
  1328. { Compile the finalize }
  1329. codegen_newprocedure;
  1330. gen_main_procsym(current_module^.modulename^+'_finalize',potype_unitfinalize,st);
  1331. names.init;
  1332. names.insert('FINALIZE$$'+current_module^.modulename^);
  1333. names.insert(target_os.cprefix+current_module^.modulename^+'_finalize');
  1334. compile_proc_body(names,true,false);
  1335. names.done;
  1336. codegen_doneprocedure;
  1337. end;
  1338. { consume the last point }
  1339. consume(_POINT);
  1340. {$ifdef New_GDB}
  1341. write_gdb_info;
  1342. {$endIf Def New_GDB}
  1343. { leave when we got an error }
  1344. if (Errorcount>0) and not status.skip_error then
  1345. begin
  1346. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1347. status.skip_error:=true;
  1348. exit;
  1349. end;
  1350. { test static symtable }
  1351. if (Errorcount=0) then
  1352. begin
  1353. st^.allsymbolsused;
  1354. st^.allprivatesused;
  1355. end;
  1356. { generate imports }
  1357. if current_module^.uses_imports then
  1358. importlib^.generatelib;
  1359. if islibrary or
  1360. (target_info.target=target_i386_WIN32) then
  1361. exportlib^.generatelib;
  1362. { insert heap }
  1363. insertResourceTablesTable;
  1364. insertinitfinaltable;
  1365. insertheap;
  1366. inserttargetspecific;
  1367. datasize:=symtablestack^.datasize;
  1368. { finish asmlist by adding segment starts }
  1369. insertsegment;
  1370. { insert own objectfile }
  1371. insertobjectfile;
  1372. { assemble and link }
  1373. create_objectfile;
  1374. { leave when we got an error }
  1375. if (Errorcount>0) and not status.skip_error then
  1376. begin
  1377. Message1(unit_f_errors_in_unit,tostr(Errorcount));
  1378. status.skip_error:=true;
  1379. exit;
  1380. end;
  1381. { create the executable when we are at level 1 }
  1382. if (compile_level=1) then
  1383. begin
  1384. { insert all .o files from all loaded units }
  1385. hp:=pmodule(loaded_units.first);
  1386. while assigned(hp) do
  1387. begin
  1388. Linker^.AddModuleFiles(hp);
  1389. hp:=pmodule(hp^.next);
  1390. end;
  1391. { write .def file }
  1392. if (cs_link_deffile in aktglobalswitches) then
  1393. deffile.writefile;
  1394. { finally we can create a executable }
  1395. if (not current_module^.is_unit) then
  1396. begin
  1397. if DLLSource then
  1398. Linker^.MakeSharedLibrary
  1399. else
  1400. Linker^.MakeExecutable;
  1401. end;
  1402. end;
  1403. end;
  1404. end.
  1405. {
  1406. $Log$
  1407. Revision 1.178 2000-01-07 01:14:29 peter
  1408. * updated copyright to 2000
  1409. Revision 1.177 1999/12/20 22:29:26 pierre
  1410. * relocation with debug info in rva (only with internal compiler)
  1411. Revision 1.176 1999/12/10 10:02:53 peter
  1412. * only check relocsection for win32
  1413. Revision 1.175 1999/11/30 10:40:44 peter
  1414. + ttype, tsymlist
  1415. Revision 1.174 1999/11/29 16:24:52 pierre
  1416. * bug in previous commit corrected
  1417. Revision 1.173 1999/11/29 15:18:27 pierre
  1418. + allow exports in win32 executables
  1419. Revision 1.172 1999/11/24 11:41:05 pierre
  1420. * defaultsymtablestack is now restored after parser.compile
  1421. Revision 1.171 1999/11/22 22:21:46 pierre
  1422. * Compute correct Exe Filenam
  1423. Revision 1.170 1999/11/22 00:23:09 pierre
  1424. * also complain about unused functions in program
  1425. Revision 1.169 1999/11/20 01:19:10 pierre
  1426. * DLL index used for win32 target with DEF file
  1427. + DLL initialization/finalization support
  1428. Revision 1.168 1999/11/18 23:35:40 pierre
  1429. * avoid double warnings
  1430. Revision 1.167 1999/11/18 15:34:47 pierre
  1431. * Notes/Hints for local syms changed to
  1432. Set_varstate function
  1433. Revision 1.166 1999/11/17 17:05:02 pierre
  1434. * Notes/hints changes
  1435. Revision 1.165 1999/11/15 15:03:47 pierre
  1436. * Pavel's changes for reloc section in executable
  1437. + warning that -g needs -WN under win32
  1438. Revision 1.164 1999/11/09 23:46:00 pierre
  1439. * power search for ** operator not in browser
  1440. * DBX support work, still does not work !
  1441. Revision 1.163 1999/11/09 13:00:37 peter
  1442. * define FPC_DELPHI,FPC_OBJFPC,FPC_TP,FPC_GPC
  1443. * initial support for ansistring default with modes
  1444. Revision 1.162 1999/11/06 14:34:22 peter
  1445. * truncated log to 20 revs
  1446. Revision 1.161 1999/11/02 15:06:57 peter
  1447. * import library fixes for win32
  1448. * alignment works again
  1449. Revision 1.160 1999/10/21 14:29:37 peter
  1450. * redesigned linker object
  1451. + library support for linux (only procedures can be exported)
  1452. Revision 1.159 1999/10/12 21:20:45 florian
  1453. * new codegenerator compiles again
  1454. Revision 1.158 1999/10/03 19:44:42 peter
  1455. * removed objpasunit reference, tvarrec is now searched in systemunit
  1456. where it already was located
  1457. Revision 1.157 1999/09/27 23:44:54 peter
  1458. * procinfo is now a pointer
  1459. * support for result setting in sub procedure
  1460. Revision 1.156 1999/09/20 16:39:00 peter
  1461. * cs_create_smart instead of cs_smartlink
  1462. * -CX is create smartlink
  1463. * -CD is create dynamic, but does nothing atm.
  1464. Revision 1.155 1999/09/16 23:05:54 florian
  1465. * m68k compiler is again compilable (only gas writer, no assembler reader)
  1466. Revision 1.154 1999/09/16 14:18:12 pierre
  1467. + warning if truncate unit name found
  1468. Revision 1.153 1999/09/13 22:56:17 peter
  1469. * fixed crashes under plain dos
  1470. Revision 1.152 1999/09/01 22:18:42 peter
  1471. * moved parsing interface/implementation to -vu
  1472. Revision 1.151 1999/08/31 15:51:10 pierre
  1473. * in_second_compile cleaned up, in_compile and in_second_load added
  1474. Revision 1.150 1999/08/30 16:21:40 pierre
  1475. * tempclosing of ppufiles under dos was wrong
  1476. Revision 1.149 1999/08/28 15:34:19 florian
  1477. * bug 519 fixed
  1478. Revision 1.148 1999/08/27 14:53:00 pierre
  1479. * double checksum problem solved
  1480. Revision 1.147 1999/08/27 10:57:56 pierre
  1481. + define SHORT_ON_FILE_HANDLES for DOS targets
  1482. causes tempclose of ppufiles
  1483. + double_checksum code released
  1484. (you can try with -dDONT_USE_DOUBLE_CHECKSUM to see the difference)
  1485. this allow second compilation of compiler without any
  1486. unit recompilation !!!!
  1487. Revision 1.146 1999/08/26 21:16:21 peter
  1488. * write date of the compiler into the executable
  1489. Revision 1.145 1999/08/26 20:24:44 michael
  1490. + Hopefuly last fixes for resourcestrings
  1491. Revision 1.144 1999/08/24 22:38:53 michael
  1492. * more resourcestring changes
  1493. Revision 1.143 1999/08/24 12:01:34 michael
  1494. + changes for resourcestrings
  1495. Revision 1.142 1999/08/16 15:35:27 pierre
  1496. * fix for DLL relocation problems
  1497. * external bss vars had wrong stabs for pecoff
  1498. + -WB11000000 to specify default image base, allows to
  1499. load several DLLs with debugging info included
  1500. (relocatable DLL are stripped because the relocation
  1501. of the .Stab section is misplaced by ldw)
  1502. }