pmodules.pas 56 KB

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