pmodules.pas 60 KB

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