123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463 |
- {
- Copyright (c) 1998-2008 by Florian Klaempfl
- Handles the parsing and loading of the modules (ppufiles)
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit pmodules;
- {$i fpcdefs.inc}
- interface
- function proc_unit:boolean;
- procedure proc_package;
- procedure proc_program(islibrary : boolean);
- implementation
- uses
- SysUtils,
- globtype,systems,tokens,
- cutils,cfileutl,cclasses,comphook,
- globals,verbose,fmodule,finput,fppu,globstat,fpcp,fpkg,
- symconst,symbase,symtype,symdef,symsym,symtable,symcreat,
- wpoinfo,
- aasmtai,aasmdata,aasmbase,aasmcpu,
- cgbase,ngenutil,
- nbas,nutils,ncgutil,
- link,assemble,import,export,gendef,ppu,comprsrc,dbgbase,
- cresstr,procinfo,
- objcgutl,
- pkgutil,
- wpobase,
- scanner,pbase,pexpr,psystem,psub,pdecsub,pgenutil,pparautl,ncgvmt,ncgrtti,
- cpuinfo;
- procedure create_objectfile;
- var
- DLLScanner : TDLLScanner;
- s : string;
- KeepShared : TCmdStrList;
- begin
- { try to create import entries from system dlls }
- if (tf_has_dllscanner in target_info.flags) and
- (not current_module.linkOtherSharedLibs.Empty) then
- begin
- { Init DLLScanner }
- if assigned(CDLLScanner[target_info.system]) then
- DLLScanner:=CDLLScanner[target_info.system].Create
- else
- internalerror(200104121);
- KeepShared:=TCmdStrList.Create;
- { Walk all shared libs }
- While not current_module.linkOtherSharedLibs.Empty do
- begin
- S:=current_module.linkOtherSharedLibs.Getusemask(link_always);
- if not DLLScanner.scan(s) then
- KeepShared.Concat(s);
- end;
- DLLscanner.Free;
- { Recreate import section }
- if (target_info.system in [system_i386_win32,system_i386_wdosx]) then
- begin
- if assigned(current_asmdata.asmlists[al_imports]) then
- current_asmdata.asmlists[al_imports].clear
- else
- current_asmdata.asmlists[al_imports]:=TAsmList.Create;
- importlib.generatelib;
- end;
- { Readd the not processed files }
- while not KeepShared.Empty do
- begin
- s:=KeepShared.GetFirst;
- current_module.linkOtherSharedLibs.add(s,link_always);
- end;
- KeepShared.Free;
- end;
- { allow a target-specific pass over all assembler code (used by LLVM
- to insert type definitions }
- cnodeutils.InsertObjectInfo;
- { Start and end module debuginfo, at least required for stabs
- to insert n_sourcefile lines }
- if (cs_debuginfo in current_settings.moduleswitches) or
- (cs_use_lineinfo in current_settings.globalswitches) then
- current_debuginfo.insertmoduleinfo;
- { create the .s file and assemble it }
- if not(create_smartlink_library) or not(tf_no_objectfiles_when_smartlinking in target_info.flags) then
- GenerateAsm(false);
- { Also create a smartlinked version ? }
- if create_smartlink_library then
- begin
- GenerateAsm(true);
- if (af_needar in target_asm.flags) then
- Linker.MakeStaticLibrary;
- end;
- { resource files }
- CompileResourceFiles;
- end;
- procedure insertobjectfile;
- { Insert the used object file for this unit in the used list for this unit }
- begin
- current_module.linkunitofiles.add(current_module.objfilename,link_static);
- current_module.flags:=current_module.flags or uf_static_linked;
- if create_smartlink_library then
- begin
- current_module.linkunitstaticlibs.add(current_module.staticlibfilename ,link_smart);
- current_module.flags:=current_module.flags or uf_smart_linked;
- end;
- end;
- procedure create_dwarf_frame;
- begin
- { Dwarf conflicts with smartlinking in separate .a files }
- if create_smartlink_library then
- exit;
- { Call frame information }
- { MWE: we write our own info, so dwarf asm support is not really needed }
- { if (af_supports_dwarf in target_asm.flags) and }
- { CFI is currently broken for Darwin }
- if not(target_info.system in systems_darwin) and
- (
- (tf_needs_dwarf_cfi in target_info.flags) or
- (target_dbg.id in [dbg_dwarf2, dbg_dwarf3])
- ) then
- begin
- current_asmdata.asmlists[al_dwarf_frame].Free;
- current_asmdata.asmlists[al_dwarf_frame] := TAsmList.create;
- current_asmdata.asmcfi.generate_code(current_asmdata.asmlists[al_dwarf_frame]);
- end;
- end;
- Function CheckResourcesUsed : boolean;
- var
- hp : tused_unit;
- found : Boolean;
- begin
- CheckResourcesUsed:=tf_has_winlike_resources in target_info.flags;
- if not CheckResourcesUsed then exit;
- hp:=tused_unit(usedunits.first);
- found:=((current_module.flags and uf_has_resourcefiles)=uf_has_resourcefiles);
- If not found then
- While Assigned(hp) and not found do
- begin
- Found:=((hp.u.flags and uf_has_resourcefiles)=uf_has_resourcefiles);
- hp:=tused_unit(hp.next);
- end;
- CheckResourcesUsed:=found;
- end;
- function AddUnit(const s:string;addasused:boolean): tppumodule;
- var
- hp : tppumodule;
- unitsym : tunitsym;
- begin
- { load unit }
- hp:=registerunit(current_module,s,'');
- hp.loadppu;
- hp.adddependency(current_module);
- { add to symtable stack }
- symtablestack.push(hp.globalsymtable);
- if (m_mac in current_settings.modeswitches) and
- assigned(hp.globalmacrosymtable) then
- macrosymtablestack.push(hp.globalmacrosymtable);
- { insert unitsym }
- unitsym:=cunitsym.create(hp.modulename^,hp);
- inc(unitsym.refs);
- tabstractunitsymtable(current_module.localsymtable).insertunit(unitsym);
- if addasused then
- { add to used units }
- current_module.addusedunit(hp,false,unitsym);
- result:=hp;
- end;
- function AddUnit(const s:string):tppumodule;
- begin
- result:=AddUnit(s,true);
- end;
- procedure maybeloadvariantsunit;
- var
- hp : tmodule;
- begin
- { Do we need the variants unit? Skip this
- for VarUtils unit for bootstrapping }
- if (current_module.flags and uf_uses_variants=0) or
- (current_module.modulename^='VARUTILS') then
- exit;
- { Variants unit already loaded? }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- if hp.modulename^='VARIANTS' then
- exit;
- hp:=tmodule(hp.next);
- end;
- { Variants unit is not loaded yet, load it now }
- Message(parser_w_implicit_uses_of_variants_unit);
- AddUnit('variants');
- end;
- function MaybeRemoveResUnit : boolean;
- var
- resources_used : boolean;
- hp : tmodule;
- uu : tused_unit;
- unitname : shortstring;
- begin
- { We simply remove the unit from:
- - usedunit list, so that things like init/finalization table won't
- contain references to this unit
- - loaded_units list, so that the unit object file doesn't get linked
- with the executable. }
- { Note: on windows we always need resources! }
- resources_used:=(target_info.system in systems_all_windows)
- or CheckResourcesUsed;
- if (not resources_used) and (tf_has_winlike_resources in target_info.flags) then
- begin
- { resources aren't used, so we don't need this unit }
- if target_res.id=res_ext then
- unitname:='FPEXTRES'
- else
- unitname:='FPINTRES';
- Message1(unit_u_unload_resunit,unitname);
- { find the module }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- if hp.is_unit and (hp.modulename^=unitname) then break;
- hp:=tmodule(hp.next);
- end;
- if not assigned(hp) then
- internalerror(200801071);
- { find its tused_unit in the global list }
- uu:=tused_unit(usedunits.first);
- while assigned(uu) do
- begin
- if uu.u=hp then break;
- uu:=tused_unit(uu.next);
- end;
- if not assigned(uu) then
- internalerror(200801072);
- { remove the tused_unit }
- usedunits.Remove(uu);
- uu.Free;
- { remove the module }
- loaded_units.Remove(hp);
- unloaded_units.Concat(hp);
- end;
- MaybeRemoveResUnit:=resources_used;
- end;
- procedure loadsystemunit;
- begin
- { we are going to rebuild the symtablestack, clear it first }
- symtablestack.clear;
- macrosymtablestack.clear;
- { macro symtable }
- macrosymtablestack.push(initialmacrosymtable);
- { are we compiling the system unit? }
- if (cs_compilesystem in current_settings.moduleswitches) then
- begin
- systemunit:=tglobalsymtable(current_module.localsymtable);
- { create system defines }
- create_intern_types;
- create_intern_symbols;
- { Set the owner of errorsym and errortype to symtable to
- prevent crashes when accessing .owner }
- generrorsym.owner:=systemunit;
- generrordef.owner:=systemunit;
- exit;
- end;
- { insert the system unit, it is allways the first. Load also the
- internal types from the system unit }
- AddUnit('system');
- systemunit:=tglobalsymtable(symtablestack.top);
- load_intern_types;
- { Set the owner of errorsym and errortype to symtable to
- prevent crashes when accessing .owner }
- generrorsym.owner:=systemunit;
- generrordef.owner:=systemunit;
- end;
- procedure loaddefaultunits;
- begin
- { Units only required for main module }
- if not(current_module.is_unit) then
- begin
- { Heaptrc unit, load heaptrace before any other units especially objpas }
- if (cs_use_heaptrc in current_settings.globalswitches) then
- AddUnit('heaptrc');
- { Valgrind requires c memory manager }
- if (cs_gdb_valgrind in current_settings.globalswitches) then
- AddUnit('cmem');
- { Lineinfo unit }
- if (cs_use_lineinfo in current_settings.globalswitches) then begin
- case target_dbg.id of
- dbg_stabs:
- AddUnit('lineinfo');
- dbg_stabx:
- AddUnit('lnfogdb');
- else
- AddUnit('lnfodwrf');
- end;
- end;
- {$ifdef cpufpemu}
- { Floating point emulation unit?
- softfpu must be in the system unit anyways (FK)
- if (cs_fp_emulation in current_settings.moduleswitches) and not(target_info.system in system_wince) then
- AddUnit('softfpu');
- }
- {$endif cpufpemu}
- { Which kind of resource support?
- Note: if resources aren't used this unit will be removed later,
- otherwise we need it here since it must be loaded quite early }
- if (tf_has_winlike_resources in target_info.flags) then
- if target_res.id=res_ext then
- AddUnit('fpextres')
- else
- AddUnit('fpintres');
- end
- else if (cs_checkpointer in current_settings.localswitches) then
- AddUnit('heaptrc');
- { Objpas unit? }
- if m_objpas in current_settings.modeswitches then
- AddUnit('objpas');
- { Macpas unit? }
- if m_mac in current_settings.modeswitches then
- AddUnit('macpas');
- if m_iso in current_settings.modeswitches then
- AddUnit('iso7185');
- if m_extpas in current_settings.modeswitches then
- begin
- { basic procedures for Extended Pascal are for now provided by the iso unit }
- AddUnit('iso7185');
- AddUnit('extpas');
- end;
- { blocks support? }
- if m_blocks in current_settings.modeswitches then
- AddUnit('blockrtl');
- { default char=widechar? }
- if m_default_unicodestring in current_settings.modeswitches then
- AddUnit('uuchar');
- { Objective-C support unit? }
- if (m_objectivec1 in current_settings.modeswitches) then
- begin
- { interface to Objective-C run time }
- AddUnit('objc');
- loadobjctypes;
- { NSObject }
- if not(current_module.is_unit) or
- (current_module.modulename^<>'OBJCBASE') then
- AddUnit('objcbase');
- end;
- { Profile unit? Needed for go32v2 only }
- if (cs_profile in current_settings.moduleswitches) and
- (target_info.system in [system_i386_go32v2,system_i386_watcom]) then
- AddUnit('profile');
- if (cs_load_fpcylix_unit in current_settings.globalswitches) then
- begin
- AddUnit('fpcylix');
- AddUnit('dynlibs');
- end;
- {$push}
- {$warn 6018 off} { Unreachable code due to compile time evaluation }
- { CPU targets with microcontroller support can add a controller specific unit }
- if ControllerSupport and (target_info.system in systems_embedded) and
- (current_settings.controllertype<>ct_none) and
- (embedded_controllers[current_settings.controllertype].controllerunitstr<>'') then
- AddUnit(embedded_controllers[current_settings.controllertype].controllerunitstr);
- {$pop}
- end;
- procedure loadautounits;
- var
- hs,s : string;
- begin
- hs:=autoloadunits;
- repeat
- s:=GetToken(hs,',');
- if s='' then
- break;
- AddUnit(s);
- until false;
- end;
- procedure loadunits(preservest:tsymtable);
- var
- s,sorg : ansistring;
- fn : string;
- pu,pu2 : tused_unit;
- hp2 : tmodule;
- unitsym : tunitsym;
- filepos : tfileposinfo;
- begin
- consume(_USES);
- repeat
- s:=pattern;
- sorg:=orgpattern;
- filepos:=current_tokenpos;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- s:=s+'.'+pattern;
- sorg:=sorg+'.'+orgpattern;
- consume(_ID);
- end;
- { support "<unit> in '<file>'" construct, but not for tp7 }
- fn:='';
- if not(m_tp7 in current_settings.modeswitches) and
- try_to_consume(_OP_IN) then
- fn:=FixFileName(get_stringconst);
- { Give a warning if lineinfo is loaded }
- if s='LINEINFO' then
- begin
- Message(parser_w_no_lineinfo_use_switch);
- if (target_dbg.id in [dbg_dwarf2, dbg_dwarf3]) then
- s := 'LNFODWRF';
- sorg := s;
- end;
- { Give a warning if objpas is loaded }
- if s='OBJPAS' then
- Message(parser_w_no_objpas_use_mode);
- { Using the unit itself is not possible }
- if (s<>current_module.modulename^) then
- begin
- { check if the unit is already used }
- hp2:=nil;
- pu:=tused_unit(current_module.used_units.first);
- while assigned(pu) do
- begin
- if (pu.u.modulename^=s) then
- begin
- hp2:=pu.u;
- break;
- end;
- pu:=tused_unit(pu.next);
- end;
- if not assigned(hp2) then
- hp2:=registerunit(current_module,sorg,fn)
- else
- Message1(sym_e_duplicate_id,s);
- { Create unitsym, we need to use the name as specified, we
- can not use the modulename because that can be different
- when -Un is used }
- current_tokenpos:=filepos;
- unitsym:=cunitsym.create(sorg,nil);
- { the current module uses the unit hp2 }
- current_module.addusedunit(hp2,true,unitsym);
- end
- else
- Message1(sym_e_duplicate_id,s);
- if token=_COMMA then
- begin
- pattern:='';
- consume(_COMMA);
- end
- else
- break;
- until false;
- { Load the units }
- pu:=tused_unit(current_module.used_units.first);
- while assigned(pu) do
- begin
- { Only load the units that are in the current
- (interface/implementation) uses clause }
- if pu.in_uses and
- (pu.in_interface=current_module.in_interface) then
- begin
- tppumodule(pu.u).loadppu;
- { is our module compiled? then we can stop }
- if current_module.state=ms_compiled then
- exit;
- { add this unit to the dependencies }
- pu.u.adddependency(current_module);
- { save crc values }
- pu.checksum:=pu.u.crc;
- pu.interface_checksum:=pu.u.interface_crc;
- pu.indirect_checksum:=pu.u.indirect_crc;
- if tppumodule(pu.u).nsprefix<>'' then
- begin
- { use the name as declared in the uses section for -Un }
- sorg:=tppumodule(pu.u).nsprefix+'.'+pu.unitsym.realname;
- s:=upper(sorg);
- { check whether the module was already loaded }
- hp2:=nil;
- pu2:=tused_unit(current_module.used_units.first);
- while assigned(pu2) and (pu2<>pu) do
- begin
- if (pu2.u.modulename^=s) then
- begin
- hp2:=pu.u;
- break;
- end;
- pu2:=tused_unit(pu2.next);
- end;
- if assigned(hp2) then
- begin
- MessagePos1(pu.unitsym.fileinfo,sym_e_duplicate_id,s);
- pu:=tused_unit(pu.next);
- continue;
- end;
- { update unitsym now that we have access to the full name }
- pu.unitsym.free;
- pu.unitsym:=cunitsym.create(sorg,pu.u);
- end
- else
- begin
- { connect unitsym to the module }
- pu.unitsym.module:=pu.u;
- pu.unitsym.register_sym;
- end;
- tabstractunitsymtable(current_module.localsymtable).insertunit(pu.unitsym);
- { add to symtable stack }
- if assigned(preservest) then
- symtablestack.pushafter(pu.u.globalsymtable,preservest)
- else
- symtablestack.push(pu.u.globalsymtable);
- if (m_mac in current_settings.modeswitches) and
- assigned(pu.u.globalmacrosymtable) then
- macrosymtablestack.push(pu.u.globalmacrosymtable);
- { check hints }
- pu.check_hints;
- end;
- pu:=tused_unit(pu.next);
- end;
- end;
- procedure reset_all_defs;
- begin
- if assigned(current_module.wpoinfo) then
- current_module.wpoinfo.resetdefs;
- end;
- procedure free_localsymtables(st:TSymtable);
- var
- i : longint;
- def : tstoreddef;
- pd : tprocdef;
- begin
- for i:=0 to st.DefList.Count-1 do
- begin
- def:=tstoreddef(st.DefList[i]);
- if def.typ=procdef then
- begin
- pd:=tprocdef(def);
- if assigned(pd.localst) and
- (pd.localst.symtabletype<>staticsymtable) and
- not(po_inline in pd.procoptions) then
- begin
- free_localsymtables(pd.localst);
- pd.localst.free;
- pd.localst:=nil;
- end;
- pd.freeimplprocdefinfo;
- pd.done_paraloc_info(calleeside);
- end;
- end;
- end;
- procedure free_unregistered_localsymtable_elements;
- var
- i: longint;
- def: tdef;
- sym: tsym;
- begin
- for i:=current_module.localsymtable.deflist.count-1 downto 0 do
- begin
- def:=tdef(current_module.localsymtable.deflist[i]);
- { this also frees def, as the defs are owned by the symtable }
- if not def.is_registered and
- not(df_not_registered_no_free in def.defoptions) then
- begin
- { if it's a procdef, unregister it from its procsym first,
- unless that sym hasn't been registered either (it's possible
- to have one overload in the interface and another in the
- implementation) }
- if (def.typ=procdef) and
- tprocdef(def).procsym.is_registered then
- tprocsym(tprocdef(def).procsym).ProcdefList.Remove(def);
- current_module.localsymtable.deletedef(def);
- end;
- end;
- { from high to low so we hopefully have moves of less data }
- for i:=current_module.localsymtable.symlist.count-1 downto 0 do
- begin
- sym:=tsym(current_module.localsymtable.symlist[i]);
- { this also frees sym, as the symbols are owned by the symtable }
- if not sym.is_registered then
- current_module.localsymtable.Delete(sym);
- end;
- end;
- procedure setupglobalswitches;
- begin
- if (cs_create_pic in current_settings.moduleswitches) then
- begin
- def_system_macro('FPC_PIC');
- def_system_macro('PIC');
- end;
- end;
- function create_main_proc(const name:string;potype:tproctypeoption;st:TSymtable):tcgprocinfo;
- var
- ps : tprocsym;
- pd : tprocdef;
- begin
- { there should be no current_procinfo available }
- if assigned(current_procinfo) then
- internalerror(200304275);
- {Generate a procsym for main}
- ps:=cprocsym.create('$'+name);
- { always register the symbol }
- ps.register_sym;
- { main are allways used }
- inc(ps.refs);
- st.insert(ps);
- pd:=tprocdef(cnodeutils.create_main_procdef(target_info.cprefix+name,potype,ps));
- { We don't need a local symtable, change it into the static symtable }
- if not (potype in [potype_mainstub,potype_pkgstub]) then
- begin
- pd.localst.free;
- pd.localst:=st;
- end
- else if (potype=potype_pkgstub) and
- (target_info.system in systems_all_windows+systems_nativent) then
- pd.proccalloption:=pocall_stdcall
- else
- pd.proccalloption:=pocall_cdecl;
- handle_calling_convention(pd,hcc_default_actions_impl);
- { set procinfo and current_procinfo.procdef }
- result:=tcgprocinfo(cprocinfo.create(nil));
- result.procdef:=pd;
- { main proc does always a call e.g. to init system unit }
- if potype<>potype_pkgstub then
- include(result.flags,pi_do_call);
- end;
- procedure release_main_proc(pi:tcgprocinfo);
- begin
- { remove localst as it was replaced by staticsymtable }
- pi.procdef.localst:=nil;
- { remove procinfo }
- current_module.procinfo:=nil;
- pi.free;
- pi:=nil;
- end;
- { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
- procedure maybe_load_got;
- {$if defined(i386) or defined (sparcgen)}
- var
- gotvarsym : tstaticvarsym;
- {$endif i386 or sparcgen}
- begin
- {$if defined(i386) or defined(sparcgen)}
- if (cs_create_pic in current_settings.moduleswitches) and
- (tf_pic_uses_got in target_info.flags) then
- begin
- { insert symbol for got access in assembler code}
- gotvarsym:=cstaticvarsym.create('_GLOBAL_OFFSET_TABLE_',
- vs_value,voidpointertype,[vo_is_external]);
- gotvarsym.set_mangledname('_GLOBAL_OFFSET_TABLE_');
- current_module.localsymtable.insert(gotvarsym);
- { avoid unnecessary warnings }
- gotvarsym.varstate:=vs_read;
- gotvarsym.refs:=1;
- end;
- {$endif i386 or sparcgen}
- end;
- function gen_implicit_initfinal(flag:word;st:TSymtable):tcgprocinfo;
- begin
- { create procdef }
- case flag of
- uf_init :
- begin
- result:=create_main_proc(make_mangledname('',current_module.localsymtable,'init_implicit$'),potype_unitinit,st);
- result.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
- end;
- uf_finalize :
- begin
- result:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize_implicit$'),potype_unitfinalize,st);
- result.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
- if (not current_module.is_unit) then
- result.procdef.aliasnames.insert('PASCALFINALIZE');
- end;
- else
- internalerror(200304253);
- end;
- result.code:=cnothingnode.create;
- end;
- procedure copy_macro(p:TObject; arg:pointer);
- begin
- current_module.globalmacrosymtable.insert(tmacro(p).getcopy);
- end;
- function try_consume_hintdirective(var moduleopt:tmoduleoptions; var deprecatedmsg:pshortstring):boolean;
- var
- deprecated_seen,
- last_is_deprecated:boolean;
- begin
- try_consume_hintdirective:=false;
- deprecated_seen:=false;
- repeat
- last_is_deprecated:=false;
- case idtoken of
- _LIBRARY :
- begin
- include(moduleopt,mo_hint_library);
- try_consume_hintdirective:=true;
- end;
- _DEPRECATED :
- begin
- { allow deprecated only once }
- if deprecated_seen then
- break;
- include(moduleopt,mo_hint_deprecated);
- try_consume_hintdirective:=true;
- last_is_deprecated:=true;
- deprecated_seen:=true;
- end;
- _EXPERIMENTAL :
- begin
- include(moduleopt,mo_hint_experimental);
- try_consume_hintdirective:=true;
- end;
- _PLATFORM :
- begin
- include(moduleopt,mo_hint_platform);
- try_consume_hintdirective:=true;
- end;
- _UNIMPLEMENTED :
- begin
- include(moduleopt,mo_hint_unimplemented);
- try_consume_hintdirective:=true;
- end;
- else
- break;
- end;
- consume(Token);
- { handle deprecated message }
- if ((token=_CSTRING) or (token=_CCHAR)) and last_is_deprecated then
- begin
- if deprecatedmsg<>nil then
- internalerror(201001221);
- if token=_CSTRING then
- deprecatedmsg:=stringdup(cstringpattern)
- else
- deprecatedmsg:=stringdup(pattern);
- consume(token);
- include(moduleopt,mo_has_deprecated_msg);
- end;
- until false;
- end;
- {$ifdef jvm}
- procedure addmoduleclass;
- var
- def: tobjectdef;
- typesym: ttypesym;
- begin
- { java_jlobject may not have been parsed yet (system unit); in any
- case, we only use this to refer to the class type, so inheritance
- does not matter }
- def:=cobjectdef.create(odt_javaclass,'__FPC_JVM_Module_Class_Alias$',nil,true);
- include(def.objectoptions,oo_is_external);
- include(def.objectoptions,oo_is_sealed);
- def.objextname:=stringdup(current_module.realmodulename^);
- typesym:=ctypesym.create('__FPC_JVM_Module_Class_Alias$',def);
- symtablestack.top.insert(typesym);
- end;
- {$endif jvm}
- type
- tfinishstate=record
- init_procinfo:tcgprocinfo;
- finalize_procinfo:tcgprocinfo;
- end;
- pfinishstate=^tfinishstate;
- procedure finish_unit(module:tmodule;immediate:boolean);forward;
- function proc_unit:boolean;
- var
- main_file: tinputfile;
- s1,s2 : ^string; {Saves stack space}
- finalize_procinfo,
- init_procinfo : tcgprocinfo;
- unitname : ansistring;
- unitname8 : string[8];
- i,j : longint;
- finishstate:pfinishstate;
- globalstate:pglobalstate;
- consume_semicolon_after_uses:boolean;
- feature : tfeature;
- begin
- result:=true;
- init_procinfo:=nil;
- finalize_procinfo:=nil;
- if m_mac in current_settings.modeswitches then
- current_module.mode_switch_allowed:= false;
- consume(_UNIT);
- if compile_level=1 then
- Status.IsExe:=false;
- unitname:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- unitname:=unitname+'.'+orgpattern;
- consume(_ID);
- end;
- { create filenames and unit name }
- main_file := current_scanner.inputfile;
- while assigned(main_file.next) do
- main_file := main_file.next;
- new(s1);
- s1^:=current_module.modulename^;
- current_module.SetFileName(main_file.path+main_file.name,true);
- current_module.SetModuleName(unitname);
- { check for system unit }
- new(s2);
- s2^:=upper(ChangeFileExt(ExtractFileName(main_file.name),''));
- unitname8:=copy(current_module.modulename^,1,8);
- if (cs_check_unit_name in current_settings.globalswitches) and
- (
- not(
- (current_module.modulename^=s2^) or
- (
- (length(current_module.modulename^)>8) and
- (unitname8=s2^)
- )
- )
- or
- (
- (length(s1^)>8) and
- (s1^<>current_module.modulename^)
- )
- ) then
- Message2(unit_e_illegal_unit_name,current_module.realmodulename^,s1^);
- if (current_module.modulename^='SYSTEM') then
- include(current_settings.moduleswitches,cs_compilesystem);
- dispose(s2);
- dispose(s1);
- if (target_info.system in systems_unit_program_exports) then
- exportlib.preparelib(current_module.realmodulename^);
- { parse hint directives }
- try_consume_hintdirective(current_module.moduleoptions, current_module.deprecatedmsg);
- consume(_SEMICOLON);
- { handle the global switches, do this before interface, because after interface has been
- read, all following directives are parsed as well }
- setupglobalswitches;
- { generate now the global symboltable,
- define first as local to overcome dependency conflicts }
- current_module.localsymtable:=tglobalsymtable.create(current_module.modulename^,current_module.moduleid);
- { insert unitsym of this unit to prevent other units having
- the same name }
- tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
- { load default system unit, it must be loaded before interface is parsed
- else we cannot use e.g. feature switches before the next real token }
- loadsystemunit;
- { system unit is loaded, now insert feature defines }
- for feature:=low(tfeature) to high(tfeature) do
- if feature in features then
- def_system_macro('FPC_HAS_FEATURE_'+featurestr[feature]);
- consume(_INTERFACE);
- { global switches are read, so further changes aren't allowed }
- current_module.in_global:=false;
- message1(unit_u_loading_interface_units,current_module.modulename^);
- { update status }
- status.currentmodule:=current_module.realmodulename^;
- { maybe turn off m_objpas if we are compiling objpas }
- if (current_module.modulename^='OBJPAS') then
- exclude(current_settings.modeswitches,m_objpas);
- { maybe turn off m_mac if we are compiling macpas }
- if (current_module.modulename^='MACPAS') then
- exclude(current_settings.modeswitches,m_mac);
- parse_only:=true;
- { load default units, like language mode units }
- if not(cs_compilesystem in current_settings.moduleswitches) then
- loaddefaultunits;
- { insert qualifier for the system unit (allows system.writeln) }
- if not(cs_compilesystem in current_settings.moduleswitches) and
- (token=_USES) then
- begin
- loadunits(nil);
- { has it been compiled at a higher level ?}
- if current_module.state=ms_compiled then
- begin
- Message1(parser_u_already_compiled,current_module.realmodulename^);
- exit;
- end;
- consume_semicolon_after_uses:=true;
- end
- else
- consume_semicolon_after_uses:=false;
- { move the global symtable from the temporary local to global }
- current_module.globalsymtable:=current_module.localsymtable;
- current_module.localsymtable:=nil;
- { number all units, so we know if a unit is used by this unit or
- needs to be added implicitly }
- current_module.updatemaps;
- { consume the semicolon after maps have been updated else conditional compiling expressions
- might cause internal errors, see tw8611 }
- if consume_semicolon_after_uses then
- consume(_SEMICOLON);
- { create whole program optimisation information (may already be
- updated in the interface, e.g., in case of classrefdef typed
- constants }
- current_module.wpoinfo:=tunitwpoinfo.create;
- { ... parse the declarations }
- Message1(parser_u_parsing_interface,current_module.realmodulename^);
- symtablestack.push(current_module.globalsymtable);
- {$ifdef jvm}
- { fake classdef to represent the class corresponding to the unit }
- addmoduleclass;
- {$endif}
- read_interface_declarations;
- { Export macros defined in the interface for macpas. The macros
- are put in the globalmacrosymtable that will only be used by other
- units. The current unit continues to use the localmacrosymtable }
- if (m_mac in current_settings.modeswitches) then
- begin
- current_module.globalmacrosymtable:=tmacrosymtable.create(true);
- current_module.localmacrosymtable.SymList.ForEachCall(@copy_macro,nil);
- end;
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- symtablestack.pop(current_module.globalsymtable);
- exit;
- end;
- { Our interface is compiled, generate CRC and switch to implementation }
- if not(cs_compilesystem in current_settings.moduleswitches) and
- (Errorcount=0) then
- tppumodule(current_module).getppucrc;
- current_module.in_interface:=false;
- current_module.interface_compiled:=true;
- { First reload all units depending on our interface, we need to do this
- in the implementation part to prevent erroneous circular references }
- tppumodule(current_module).setdefgeneration;
- tppumodule(current_module).reload_flagged_units;
- { Parse the implementation section }
- if (m_mac in current_settings.modeswitches) and try_to_consume(_END) then
- current_module.interface_only:=true
- else
- current_module.interface_only:=false;
- parse_only:=false;
- { create static symbol table }
- current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
- { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
- maybe_load_got;
- if not current_module.interface_only then
- begin
- consume(_IMPLEMENTATION);
- Message1(unit_u_loading_implementation_units,current_module.modulename^);
- { Read the implementation units }
- if token=_USES then
- begin
- loadunits(current_module.globalsymtable);
- consume(_SEMICOLON);
- end;
- end;
- if current_module.state=ms_compiled then
- begin
- symtablestack.pop(current_module.globalsymtable);
- exit;
- end;
- { All units are read, now give them a number }
- current_module.updatemaps;
- { further, changing the globalsymtable is not allowed anymore }
- current_module.globalsymtable.sealed:=true;
- symtablestack.push(current_module.localsymtable);
- if not current_module.interface_only then
- begin
- Message1(parser_u_parsing_implementation,current_module.modulename^);
- if current_module.in_interface then
- internalerror(200212285);
- { Compile the unit }
- init_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'init$'),potype_unitinit,current_module.localsymtable);
- init_procinfo.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
- init_procinfo.parse_body;
- { save file pos for debuginfo }
- current_module.mainfilepos:=init_procinfo.entrypos;
- { parse finalization section }
- if token=_FINALIZATION then
- begin
- { Compile the finalize }
- finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize$'),potype_unitfinalize,current_module.localsymtable);
- finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
- finalize_procinfo.parse_body;
- end
- end;
- { remove all units that we are waiting for that are already waiting for
- us => breaking up circles }
- for i:=0 to current_module.waitingunits.count-1 do
- for j:=current_module.waitingforunit.count-1 downto 0 do
- if current_module.waitingunits[i]=current_module.waitingforunit[j] then
- current_module.waitingforunit.delete(j);
- {$ifdef DEBUG_UNITWAITING}
- Writeln('Units waiting for ', current_module.modulename^, ': ',
- current_module.waitingforunit.Count);
- {$endif}
- result:=current_module.waitingforunit.count=0;
- { save all information that is needed for finishing the unit }
- New(finishstate);
- finishstate^.init_procinfo:=init_procinfo;
- finishstate^.finalize_procinfo:=finalize_procinfo;
- current_module.finishstate:=finishstate;
- if result then
- finish_unit(current_module,true)
- else
- begin
- { save the current state, so the parsing can continue where we left
- of here }
- New(globalstate);
- save_global_state(globalstate^,true);
- current_module.globalstate:=globalstate;
- end;
- end;
- procedure finish_unit(module:tmodule;immediate:boolean);
- function is_assembler_generated:boolean;
- var
- hal : tasmlisttype;
- begin
- result:=false;
- if Errorcount=0 then
- begin
- for hal:=low(TasmlistType) to high(TasmlistType) do
- if not current_asmdata.asmlists[hal].empty then
- begin
- result:=true;
- exit;
- end;
- end;
- end;
- procedure module_is_done;inline;
- begin
- dispose(pglobalstate(current_module.globalstate));
- current_module.globalstate:=nil;
- dispose(pfinishstate(current_module.finishstate));
- current_module.finishstate:=nil;
- end;
- var
- {$ifdef EXTDEBUG}
- store_crc,
- {$endif EXTDEBUG}
- store_interface_crc,
- store_indirect_crc: cardinal;
- force_init_final : boolean;
- init_procinfo,
- finalize_procinfo : tcgprocinfo;
- i : longint;
- ag : boolean;
- finishstate : tfinishstate;
- globalstate : tglobalstate;
- waitingmodule : tmodule;
- begin
- fillchar(globalstate,sizeof(tglobalstate),0);
- if not immediate then
- begin
- {$ifdef DEBUG_UNITWAITING}
- writeln('finishing waiting unit ''', module.modulename^, '''');
- {$endif DEBUG_UNITWAITING}
- { restore the state when we stopped working on the unit }
- save_global_state(globalstate,true);
- if not assigned(module.globalstate) then
- internalerror(2012091802);
- restore_global_state(pglobalstate(module.globalstate)^,true);
- end;
- { current_module is now module }
- if not assigned(current_module.finishstate) then
- internalerror(2012091801);
- finishstate:=pfinishstate(current_module.finishstate)^;
- finalize_procinfo:=finishstate.finalize_procinfo;
- init_procinfo:=finishstate.init_procinfo;
- { Generate specializations of objectdefs methods }
- generate_specialization_procs;
- { Generate VMTs }
- if Errorcount=0 then
- begin
- write_vmts(current_module.globalsymtable,true);
- write_vmts(current_module.localsymtable,false);
- end;
- { add implementations for synthetic method declarations added by
- the compiler }
- add_synthetic_method_implementations(current_module.globalsymtable);
- add_synthetic_method_implementations(current_module.localsymtable);
- { if the unit contains ansi/widestrings, initialization and
- finalization code must be forced }
- force_init_final:=tglobalsymtable(current_module.globalsymtable).needs_init_final or
- tstaticsymtable(current_module.localsymtable).needs_init_final;
- { should we force unit initialization? }
- { this is a hack, but how can it be done better ? }
- { Now the sole purpose of this is to change 'init' to 'init_implicit',
- is it needed at all? (Sergei) }
- { it's needed in case cnodeutils.force_init = true }
- if (force_init_final or cnodeutils.force_init) and
- (
- not assigned(init_procinfo) or
- has_no_code(init_procinfo.code)
- ) then
- begin
- { first release the not used init procinfo }
- if assigned(init_procinfo) then
- begin
- release_proc_symbol(init_procinfo.procdef);
- release_main_proc(init_procinfo);
- end;
- init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable);
- end;
- if (force_init_final or cnodeutils.force_final) and
- (
- not assigned(finalize_procinfo) or
- has_no_code(finalize_procinfo.code)
- ) then
- begin
- { first release the not used finalize procinfo }
- if assigned(finalize_procinfo) then
- begin
- release_proc_symbol(finalize_procinfo.procdef);
- release_main_proc(finalize_procinfo);
- end;
- finalize_procinfo:=gen_implicit_initfinal(uf_finalize,current_module.localsymtable);
- end;
- { Now both init and finalize bodies are read and it is known
- which variables are used in both init and finalize we can now
- generate the code. This is required to prevent putting a variable in
- a register that is also used in the finalize body (PFV) }
- if assigned(init_procinfo) then
- begin
- if (force_init_final or cnodeutils.force_init) or
- not(has_no_code(init_procinfo.code)) then
- begin
- init_procinfo.code:=cnodeutils.wrap_proc_body(init_procinfo.procdef,init_procinfo.code);
- init_procinfo.generate_code;
- current_module.flags:=current_module.flags or uf_init;
- end
- else
- release_proc_symbol(init_procinfo.procdef);
- init_procinfo.resetprocdef;
- release_main_proc(init_procinfo);
- end;
- if assigned(finalize_procinfo) then
- begin
- if force_init_final or
- cnodeutils.force_init or
- not(has_no_code(finalize_procinfo.code)) then
- begin
- finalize_procinfo.code:=cnodeutils.wrap_proc_body(finalize_procinfo.procdef,finalize_procinfo.code);
- finalize_procinfo.generate_code;
- current_module.flags:=current_module.flags or uf_finalize;
- end
- else
- release_proc_symbol(finalize_procinfo.procdef);
- finalize_procinfo.resetprocdef;
- release_main_proc(finalize_procinfo);
- end;
- symtablestack.pop(current_module.localsymtable);
- symtablestack.pop(current_module.globalsymtable);
- { the last char should always be a point }
- consume(_POINT);
- { reset wpo flags for all defs }
- reset_all_defs;
- if (Errorcount=0) then
- begin
- { tests, if all (interface) forwards are resolved }
- tstoredsymtable(current_module.globalsymtable).check_forwards;
- { check if all private fields are used }
- tstoredsymtable(current_module.globalsymtable).allprivatesused;
- { test static symtable }
- tstoredsymtable(current_module.localsymtable).allsymbolsused;
- tstoredsymtable(current_module.localsymtable).allprivatesused;
- tstoredsymtable(current_module.localsymtable).check_forwards;
- tstoredsymtable(current_module.localsymtable).checklabels;
- { used units }
- current_module.allunitsused;
- end;
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- module_is_done;
- if not immediate then
- restore_global_state(globalstate,true);
- exit;
- end;
- { if an Objective-C module, generate rtti and module info }
- MaybeGenerateObjectiveCImageInfo(current_module.globalsymtable,current_module.localsymtable);
- { do we need to add the variants unit? }
- maybeloadvariantsunit;
- { generate rtti/init tables }
- write_persistent_type_info(current_module.globalsymtable,true);
- write_persistent_type_info(current_module.localsymtable,false);
- { Tables }
- cnodeutils.InsertThreadvars;
- { Resource strings }
- GenerateResourceStrings;
- { Widestring typed constants }
- cnodeutils.InsertWideInits;
- { Resourcestring references }
- cnodeutils.InsertResStrInits;
- { generate debuginfo }
- if (cs_debuginfo in current_settings.moduleswitches) then
- current_debuginfo.inserttypeinfo;
- { generate imports }
- if current_module.ImportLibraryList.Count>0 then
- importlib.generatelib;
- { insert own objectfile, or say that it's in a library
- (no check for an .o when loading) }
- ag:=is_assembler_generated;
- if ag then
- insertobjectfile
- else
- begin
- current_module.flags:=current_module.flags or uf_no_link;
- current_module.flags:=current_module.flags and not (uf_has_stabs_debuginfo or uf_has_dwarf_debuginfo);
- end;
- if ag then
- begin
- { create callframe info }
- create_dwarf_frame;
- { assemble }
- create_objectfile;
- end;
- { Write out the ppufile after the object file has been created }
- store_interface_crc:=current_module.interface_crc;
- store_indirect_crc:=current_module.indirect_crc;
- {$ifdef EXTDEBUG}
- store_crc:=current_module.crc;
- {$endif EXTDEBUG}
- if (Errorcount=0) then
- tppumodule(current_module).writeppu;
- if not(cs_compilesystem in current_settings.moduleswitches) then
- begin
- if store_interface_crc<>current_module.interface_crc then
- Message1(unit_u_interface_crc_changed,current_module.ppufilename);
- if store_indirect_crc<>current_module.indirect_crc then
- Message1(unit_u_indirect_crc_changed,current_module.ppufilename);
- end;
- {$ifdef EXTDEBUG}
- if not(cs_compilesystem in current_settings.moduleswitches) then
- if (store_crc<>current_module.crc) then
- Message1(unit_u_implementation_crc_changed,current_module.ppufilename);
- {$endif EXTDEBUG}
- { release unregistered defs/syms from the localsymtable }
- free_unregistered_localsymtable_elements;
- { release local symtables that are not needed anymore }
- free_localsymtables(current_module.globalsymtable);
- free_localsymtables(current_module.localsymtable);
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- module_is_done;
- if not immediate then
- restore_global_state(globalstate,true);
- exit;
- end;
- {$ifdef debug_devirt}
- { print out all instantiated class/object types }
- writeln('constructed object/class/classreftypes in ',current_module.realmodulename^);
- for i := 0 to current_module.wpoinfo.createdobjtypes.count-1 do
- begin
- write(' ',tdef(current_module.wpoinfo.createdobjtypes[i]).GetTypeName);
- case tdef(current_module.wpoinfo.createdobjtypes[i]).typ of
- objectdef:
- case tobjectdef(current_module.wpoinfo.createdobjtypes[i]).objecttype of
- odt_object:
- writeln(' (object)');
- odt_class:
- writeln(' (class)');
- else
- internalerror(2008101103);
- end;
- else
- internalerror(2008101104);
- end;
- end;
- for i := 0 to current_module.wpoinfo.createdclassrefobjtypes.count-1 do
- begin
- write(' Class Of ',tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).GetTypeName);
- case tdef(current_module.wpoinfo.createdclassrefobjtypes[i]).typ of
- objectdef:
- case tobjectdef(current_module.wpoinfo.createdclassrefobjtypes[i]).objecttype of
- odt_class:
- writeln(' (classrefdef)');
- else
- internalerror(2008101105);
- end
- else
- internalerror(2008101102);
- end;
- end;
- {$endif debug_devirt}
- Message1(unit_u_finished_compiling,current_module.modulename^);
- module_is_done;
- if not immediate then
- restore_global_state(globalstate,true);
- for i:=0 to module.waitingunits.count-1 do
- begin
- waitingmodule:=tmodule(module.waitingunits[i]);
- waitingmodule.waitingforunit.remove(module);
- { only finish the module if it isn't already finished }
- if (waitingmodule.waitingforunit.count=0) and
- assigned(waitingmodule.finishstate) then
- begin
- finish_unit(waitingmodule,false);
- waitingmodule.end_of_parsing;
- end;
- end;
- end;
- procedure proc_package;
- var
- main_file : tinputfile;
- hp,hp2 : tmodule;
- pkg : tpcppackage;
- {finalize_procinfo,
- init_procinfo,}
- main_procinfo : tcgprocinfo;
- force_init_final : boolean;
- uu : tused_unit;
- module_name: ansistring;
- pentry: ppackageentry;
- feature : tfeature;
- begin
- Status.IsPackage:=true;
- Status.IsExe:=true;
- parse_only:=false;
- main_procinfo:=nil;
- {init_procinfo:=nil;
- finalize_procinfo:=nil;}
- if not (tf_supports_packages in target_info.flags) then
- message1(parser_e_packages_not_supported,target_info.name);
- if not RelocSectionSetExplicitly then
- RelocSection:=true;
- { Relocation works only without stabs under Windows when }
- { external linker (LD) is used. LD generates relocs for }
- { stab sections which is not loaded in memory. It causes }
- { AV error when DLL is loaded and relocation is needed. }
- { Internal linker does not have this problem. }
- if RelocSection and
- (target_info.system in systems_all_windows+[system_i386_wdosx]) and
- (cs_link_extern in current_settings.globalswitches) then
- begin
- include(current_settings.globalswitches,cs_link_strip);
- { Warning stabs info does not work with reloc section !! }
- if (cs_debuginfo in current_settings.moduleswitches) and
- (target_dbg.id=dbg_stabs) then
- begin
- Message1(parser_w_parser_reloc_no_debug,current_module.mainsource);
- Message(parser_w_parser_win32_debug_needs_WN);
- exclude(current_settings.moduleswitches,cs_debuginfo);
- end;
- end;
- { get correct output names }
- main_file := current_scanner.inputfile;
- while assigned(main_file.next) do
- main_file := main_file.next;
- current_module.SetFileName(main_file.path+main_file.name,true);
- { consume _PACKAGE word }
- consume(_ID);
- module_name:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- module_name:=module_name+'.'+orgpattern;
- consume(_ID);
- end;
- current_module.setmodulename(module_name);
- current_module.ispackage:=true;
- exportlib.preparelib(module_name);
- pkg:=tpcppackage.create(module_name);
- if tf_library_needs_pic in target_info.flags then
- include(current_settings.moduleswitches,cs_create_pic);
- { setup things using the switches, do this before the semicolon, because after the semicolon has been
- read, all following directives are parsed as well }
- setupglobalswitches;
- consume(_SEMICOLON);
- { global switches are read, so further changes aren't allowed }
- current_module.in_global:=false;
- { set implementation flag }
- current_module.in_interface:=false;
- current_module.interface_compiled:=true;
- { insert after the unit symbol tables the static symbol table }
- { of the program }
- current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
- { ensure that no packages are picked up from the options }
- packagelist.clear;
- {Read the packages used by the package we compile.}
- if (token=_ID) and (idtoken=_REQUIRES) then
- begin
- { consume _REQUIRES word }
- consume(_ID);
- while true do
- begin
- if token=_ID then
- begin
- module_name:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- module_name:=module_name+'.'+orgpattern;
- consume(_ID);
- end;
- add_package(module_name,false,true);
- end
- else
- consume(_ID);
- if token=_COMMA then
- consume(_COMMA)
- else
- break;
- end;
- consume(_SEMICOLON);
- end;
- { now load all packages, so that we can determine whether a unit is
- already provided by one of the loaded packages }
- load_packages;
- if packagelist.Count>0 then
- begin
- { this means the SYSTEM unit *must* be part of one of the required
- packages, so load it }
- AddUnit('system',false);
- systemunit:=tglobalsymtable(symtablestack.top);
- load_intern_types;
- { system unit is loaded, now insert feature defines }
- for feature:=low(tfeature) to high(tfeature) do
- if feature in features then
- def_system_macro('FPC_HAS_FEATURE_'+featurestr[feature]);
- end;
- {Load the units used by the program we compile.}
- if (token=_ID) and (idtoken=_CONTAINS) then
- begin
- { consume _CONTAINS word }
- consume(_ID);
- while true do
- begin
- if token=_ID then
- begin
- module_name:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- module_name:=module_name+'.'+orgpattern;
- consume(_ID);
- end;
- hp:=AddUnit(module_name);
- if (hp.modulename^='SYSTEM') and not assigned(systemunit) then
- begin
- systemunit:=tglobalsymtable(hp.globalsymtable);
- load_intern_types;
- end;
- end
- else
- consume(_ID);
- if token=_COMMA then
- consume(_COMMA)
- else break;
- end;
- consume(_SEMICOLON);
- end;
- { All units are read, now give them a number }
- current_module.updatemaps;
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- if (hp<>current_module) and not assigned(hp.package) then
- begin
- if (hp.flags and uf_package_deny) <> 0 then
- message1(package_e_unit_deny_package,hp.realmodulename^);
- { part of the package's used, aka contained units? }
- uu:=tused_unit(current_module.used_units.first);
- while assigned(uu) do
- begin
- if uu.u=hp then
- break;
- uu:=tused_unit(uu.next);
- end;
- if not assigned(uu) then
- message2(package_n_implicit_unit_import,hp.realmodulename^,current_module.realmodulename^);
- end;
- { was this unit listed as a contained unit? If so => error }
- if (hp<>current_module) and assigned(hp.package) then
- begin
- uu:=tused_unit(current_module.used_units.first);
- while assigned(uu) do
- begin
- if uu.u=hp then
- break;
- uu:=tused_unit(uu.next);
- end;
- if assigned(uu) then
- message2(package_e_unit_already_contained_in_package,hp.realmodulename^,hp.package.realpackagename^);
- end;
- hp:=tmodule(hp.next);
- end;
- {Insert the name of the main program into the symbol table.}
- if current_module.realmodulename^<>'' then
- tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
- Message1(parser_u_parsing_implementation,current_module.mainsource);
- symtablestack.push(current_module.localsymtable);
- { create whole program optimisation information }
- current_module.wpoinfo:=tunitwpoinfo.create;
- { should we force unit initialization? }
- force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
- if force_init_final or cnodeutils.force_init then
- {init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable)};
- { Add symbol to the exports section for win32 so smartlinking a
- DLL will include the edata section }
- if assigned(exportlib) and
- (target_info.system in [system_i386_win32,system_i386_wdosx]) and
- ((current_module.flags and uf_has_exports)<>0) then
- current_asmdata.asmlists[al_procedures].concat(tai_const.createname(make_mangledname('EDATA',current_module.localsymtable,''),0));
- { all labels must be defined before generating code }
- if Errorcount=0 then
- tstoredsymtable(current_module.localsymtable).checklabels;
- symtablestack.pop(current_module.localsymtable);
- { consume the last point }
- consume(_END);
- consume(_POINT);
- if (Errorcount=0) then
- begin
- { test static symtable }
- tstoredsymtable(current_module.localsymtable).allsymbolsused;
- tstoredsymtable(current_module.localsymtable).allprivatesused;
- tstoredsymtable(current_module.localsymtable).check_forwards;
- { Note: all contained units are considered as used }
- end;
- if target_info.system in systems_all_windows+systems_nativent then
- begin
- main_procinfo:=create_main_proc('_DLLMainCRTStartup',potype_pkgstub,current_module.localsymtable);
- main_procinfo.code:=generate_pkg_stub(main_procinfo.procdef);
- main_procinfo.generate_code;
- end;
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- pkg.free;
- exit;
- end;
- { remove all unused units, this happends when units are removed
- from the uses clause in the source and the ppu was already being loaded }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- hp2:=hp;
- hp:=tmodule(hp.next);
- if assigned(hp2.package) then
- add_package_unit_ref(hp2.package);
- if hp2.is_unit and
- not assigned(hp2.globalsymtable) then
- loaded_units.remove(hp2);
- end;
- exportlib.ignoreduplicates:=true;
- { force exports }
- uu:=tused_unit(usedunits.first);
- while assigned(uu) do
- begin
- if not assigned(systemunit) and (uu.u.modulename^='SYSTEM') then
- begin
- systemunit:=tglobalsymtable(uu.u.globalsymtable);
- load_intern_types;
- end;
- if not assigned(uu.u.package) then
- export_unit(uu.u);
- uu:=tused_unit(uu.next);
- end;
- {$ifdef arm}
- { Insert .pdata section for arm-wince.
- It is needed for exception handling. }
- if target_info.system in [system_arm_wince] then
- InsertPData;
- {$endif arm}
- { generate debuginfo }
- if (cs_debuginfo in current_settings.moduleswitches) then
- current_debuginfo.inserttypeinfo;
- exportlib.generatelib;
- exportlib.ignoreduplicates:=false;
- { create import libraries for all packages }
- if packagelist.count>0 then
- createimportlibfromexternals;
- { generate imports }
- if current_module.ImportLibraryList.Count>0 then
- importlib.generatelib;
- { Reference all DEBUGINFO sections from the main .fpc section }
- if (cs_debuginfo in current_settings.moduleswitches) then
- current_debuginfo.referencesections(current_asmdata.asmlists[al_procedures]);
- { insert own objectfile }
- insertobjectfile;
- { assemble and link }
- create_objectfile;
- { We might need the symbols info if not using
- the default do_extractsymbolinfo
- which is a dummy function PM }
- needsymbolinfo:=do_extractsymbolinfo<>@def_extractsymbolinfo;
- { release all local symtables that are not needed anymore }
- if (not needsymbolinfo) then
- free_localsymtables(current_module.localsymtable);
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- pkg.free;
- exit;
- end;
- if (not current_module.is_unit) then
- begin
- { we add all loaded units that are not part of a package to the
- package; this includes units in the "contains" section as well
- as implicitely imported ones }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- if (hp<>current_module) then
- begin
- if not assigned(hp.package) then
- begin
- pkg.addunit(hp);
- check_for_indirect_package_usages(hp.used_units);
- end
- else
- begin
- pentry:=ppackageentry(packagelist.find(hp.package.packagename^));
- if not assigned(pentry) then
- internalerror(2015112301);
- pkg.add_required_package(hp.package);
- end;
- end;
- hp:=tmodule(hp.next);
- end;
- pkg.initmoduleinfo(current_module);
- { create the executable when we are at level 1 }
- if (compile_level=1) then
- begin
- { create global resource file by collecting all resource files }
- CollectResourceFiles;
- { write .def file }
- if (cs_link_deffile in current_settings.globalswitches) then
- deffile.writefile;
- { generate the pcp file }
- pkg.savepcp;
- { insert all .o files from all loaded units and
- unload the units, we don't need them anymore.
- Keep the current_module because that is still needed }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- { only link in those units which should become part of this
- package }
- if not assigned(hp.package) then
- linker.AddModuleFiles(hp);
- hp2:=tmodule(hp.next);
- if (hp<>current_module) and
- (not needsymbolinfo) then
- begin
- loaded_units.remove(hp);
- hp.free;
- end;
- hp:=hp2;
- end;
- { add the library of directly used packages }
- add_package_libs(linker);
- { and now link the package library }
- linker.MakeSharedLibrary
- end;
- { Give Fatal with error count for linker errors }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- end;
- pkg.free;
- end;
- end;
- procedure proc_program(islibrary : boolean);
- type
- TProgramParam = record
- name : ansistring;
- nr : dword;
- end;
- var
- main_file : tinputfile;
- hp,hp2 : tmodule;
- finalize_procinfo,
- init_procinfo,
- main_procinfo : tcgprocinfo;
- force_init_final : boolean;
- resources_used : boolean;
- program_uses_checkpointer : boolean;
- initname,
- program_name : ansistring;
- consume_semicolon_after_uses : boolean;
- ps : tprogramparasym;
- paramnum : longint;
- textsym : ttypesym;
- sc : array of TProgramParam;
- i : Longint;
- sysinitmod: tmodule;
- feature : tfeature;
- begin
- Status.IsLibrary:=IsLibrary;
- Status.IsPackage:=false;
- Status.IsExe:=true;
- parse_only:=false;
- main_procinfo:=nil;
- init_procinfo:=nil;
- finalize_procinfo:=nil;
- resources_used:=false;
- { make the compiler happy and avoid an uninitialized variable warning on Setlength(sc,length(sc)+1); }
- sc:=nil;
- { DLL defaults to create reloc info }
- if islibrary then
- begin
- if not RelocSectionSetExplicitly then
- RelocSection:=true;
- end;
- { Relocation works only without stabs under Windows when }
- { external linker (LD) is used. LD generates relocs for }
- { stab sections which is not loaded in memory. It causes }
- { AV error when DLL is loaded and relocation is needed. }
- { Internal linker does not have this problem. }
- if RelocSection and
- (target_info.system in systems_all_windows+[system_i386_wdosx]) and
- (cs_link_extern in current_settings.globalswitches) then
- begin
- include(current_settings.globalswitches,cs_link_strip);
- { Warning stabs info does not work with reloc section !! }
- if (cs_debuginfo in current_settings.moduleswitches) and
- (target_dbg.id=dbg_stabs) then
- begin
- Message1(parser_w_parser_reloc_no_debug,current_module.mainsource);
- Message(parser_w_parser_win32_debug_needs_WN);
- exclude(current_settings.moduleswitches,cs_debuginfo);
- end;
- end;
- { get correct output names }
- main_file := current_scanner.inputfile;
- while assigned(main_file.next) do
- main_file := main_file.next;
- current_module.SetFileName(main_file.path+main_file.name,true);
- if islibrary then
- begin
- consume(_LIBRARY);
- program_name:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- program_name:=program_name+'.'+orgpattern;
- consume(_ID);
- end;
- current_module.setmodulename(program_name);
- current_module.islibrary:=true;
- exportlib.preparelib(program_name);
- if tf_library_needs_pic in target_info.flags then
- begin
- include(current_settings.moduleswitches,cs_create_pic);
- { also set create_pic for all unit compilation }
- include(init_settings.moduleswitches,cs_create_pic);
- end;
- { setup things using the switches, do this before the semicolon, because after the semicolon has been
- read, all following directives are parsed as well }
- setupglobalswitches;
- consume(_SEMICOLON);
- end
- else
- { is there an program head ? }
- if token=_PROGRAM then
- begin
- consume(_PROGRAM);
- program_name:=orgpattern;
- consume(_ID);
- while token=_POINT do
- begin
- consume(_POINT);
- program_name:=program_name+'.'+orgpattern;
- consume(_ID);
- end;
- current_module.setmodulename(program_name);
- if (target_info.system in systems_unit_program_exports) then
- exportlib.preparelib(program_name);
- if token=_LKLAMMER then
- begin
- consume(_LKLAMMER);
- paramnum:=1;
- repeat
- if m_isolike_program_para in current_settings.modeswitches then
- begin
- if (pattern<>'INPUT') and (pattern<>'OUTPUT') then
- begin
- { the symtablestack is not setup here, so text must be created later on }
- Setlength(sc,length(sc)+1);
- with sc[high(sc)] do
- begin
- name:=pattern;
- nr:=paramnum;
- end;
- inc(paramnum);
- end;
- end;
- consume(_ID);
- until not try_to_consume(_COMMA);
- consume(_RKLAMMER);
- end;
- { setup things using the switches, do this before the semicolon, because after the semicolon has been
- read, all following directives are parsed as well }
- setupglobalswitches;
- consume(_SEMICOLON);
- end
- else
- begin
- if (target_info.system in systems_unit_program_exports) then
- exportlib.preparelib(current_module.realmodulename^);
- { setup things using the switches }
- setupglobalswitches;
- end;
- { load all packages, so we know whether a unit is contained inside a
- package or not }
- load_packages;
- { global switches are read, so further changes aren't allowed }
- current_module.in_global:=false;
- { set implementation flag }
- current_module.in_interface:=false;
- current_module.interface_compiled:=true;
- { insert after the unit symbol tables the static symbol table
- of the program }
- current_module.localsymtable:=tstaticsymtable.create(current_module.modulename^,current_module.moduleid);
- { load system unit }
- loadsystemunit;
- { system unit is loaded, now insert feature defines }
- for feature:=low(tfeature) to high(tfeature) do
- if feature in features then
- def_system_macro('FPC_HAS_FEATURE_'+featurestr[feature]);
- { load standard units, e.g objpas,profile unit }
- loaddefaultunits;
- { Load units provided on the command line }
- loadautounits;
- { insert iso program parameters }
- if length(sc)>0 then
- begin
- textsym:=search_system_type('TEXT');
- if not(assigned(textsym)) then
- internalerror(2013011201);
- for i:=0 to high(sc) do
- begin
- ps:=cprogramparasym.create(sc[i].name,sc[i].nr);
- current_module.localsymtable.insert(ps,true);
- end;
- end;
- { Load the units used by the program we compile. }
- if token=_USES then
- begin
- loadunits(nil);
- consume_semicolon_after_uses:=true;
- end
- else
- consume_semicolon_after_uses:=false;
- { All units are read, now give them a number }
- current_module.updatemaps;
- { consume the semicolon after maps have been updated else conditional compiling expressions
- might cause internal errors, see tw8611 }
- if consume_semicolon_after_uses then
- consume(_SEMICOLON);
- {Insert the name of the main program into the symbol table.}
- if current_module.realmodulename^<>'' then
- tabstractunitsymtable(current_module.localsymtable).insertunit(cunitsym.create(current_module.realmodulename^,current_module));
- Message1(parser_u_parsing_implementation,current_module.mainsource);
- symtablestack.push(current_module.localsymtable);
- {$ifdef jvm}
- { fake classdef to represent the class corresponding to the unit }
- addmoduleclass;
- {$endif}
- { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
- maybe_load_got;
- { create whole program optimisation information }
- current_module.wpoinfo:=tunitwpoinfo.create;
- { The program intialization needs an alias, so it can be called
- from the bootstrap code.}
- if islibrary then
- begin
- main_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,mainaliasname),potype_proginit,current_module.localsymtable);
- { Win32 startup code needs a single name }
- if not(target_info.system in (systems_darwin+systems_aix)) then
- main_procinfo.procdef.aliasnames.insert('PASCALMAIN')
- else
- main_procinfo.procdef.aliasnames.insert(target_info.Cprefix+'PASCALMAIN');
- { ToDo: systems that use indirect entry info, but check back with Windows! }
- if target_info.system in systems_darwin then
- { we need to call FPC_LIBMAIN in sysinit which in turn will call PascalMain }
- initname:=target_info.cprefix+'FPC_LIBMAIN'
- else
- initname:=main_procinfo.procdef.mangledname;
- { setinitname may generate a new section -> don't add to the
- current list, because we assume this remains a text section
- -- add to pure assembler section, so in case of special directives
- they are directly added to the assembler output by llvm }
- exportlib.setinitname(current_asmdata.AsmLists[al_pure_assembler],initname);
- end
- else if (target_info.system in ([system_i386_netware,system_i386_netwlibc,system_powerpc_macosclassic]+systems_darwin+systems_aix)) then
- begin
- { create a stub with the name of the desired main routine, with
- the same signature as the C "main" function, and call through to
- FPC_SYSTEMMAIN, which will initialise everything based on its
- parameters. This function cannot be in the system unit, because
- its name can be configured on the command line (for use with e.g.
- SDL, where the main function should be called SDL_main) }
- main_procinfo:=create_main_proc(mainaliasname,potype_mainstub,current_module.localsymtable);
- call_through_new_name(main_procinfo.procdef,target_info.cprefix+'FPC_SYSTEMMAIN');
- main_procinfo.free;
- { now create the PASCALMAIN routine (which will be called from
- FPC_SYSTEMMAIN) }
- main_procinfo:=create_main_proc('PASCALMAIN',potype_proginit,current_module.localsymtable);
- end
- else
- begin
- main_procinfo:=create_main_proc(mainaliasname,potype_proginit,current_module.localsymtable);
- main_procinfo.procdef.aliasnames.insert('PASCALMAIN');
- end;
- main_procinfo.parse_body;
- { save file pos for debuginfo }
- current_module.mainfilepos:=main_procinfo.entrypos;
- { finalize? }
- if token=_FINALIZATION then
- begin
- { Parse the finalize }
- finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize$'),potype_unitfinalize,current_module.localsymtable);
- finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
- finalize_procinfo.procdef.aliasnames.insert('PASCALFINALIZE');
- finalize_procinfo.parse_body;
- end;
- { Generate specializations of objectdefs methods }
- generate_specialization_procs;
- { Generate VMTs }
- if Errorcount=0 then
- write_vmts(current_module.localsymtable,false);
- { add implementations for synthetic method declarations added by
- the compiler }
- add_synthetic_method_implementations(current_module.localsymtable);
- { should we force unit initialization? }
- force_init_final:=tstaticsymtable(current_module.localsymtable).needs_init_final;
- if force_init_final or cnodeutils.force_init then
- init_procinfo:=gen_implicit_initfinal(uf_init,current_module.localsymtable);
- { Add symbol to the exports section for win32 so smartlinking a
- DLL will include the edata section }
- if assigned(exportlib) and
- (target_info.system in [system_i386_win32,system_i386_wdosx]) and
- ((current_module.flags and uf_has_exports)<>0) then
- current_asmdata.asmlists[al_procedures].concat(tai_const.createname(make_mangledname('EDATA',current_module.localsymtable,''),0));
- if (force_init_final or cnodeutils.force_final) and
- (
- not assigned(finalize_procinfo)
- or has_no_code(finalize_procinfo.code)
- ) then
- begin
- { first release the not used finalize procinfo }
- if assigned(finalize_procinfo) then
- begin
- release_proc_symbol(finalize_procinfo.procdef);
- release_main_proc(finalize_procinfo);
- end;
- finalize_procinfo:=gen_implicit_initfinal(uf_finalize,current_module.localsymtable);
- end;
- { the finalization routine of libraries is generic (and all libraries need to }
- { be finalized, so they can finalize any units they use }
- { Place in "pure assembler" list so that the llvm assembler writer
- directly emits the generated directives }
- if (islibrary) then
- exportlib.setfininame(current_asmdata.asmlists[al_pure_assembler],'FPC_LIB_EXIT');
- { all labels must be defined before generating code }
- if Errorcount=0 then
- tstoredsymtable(current_module.localsymtable).checklabels;
- { See remark in unit init/final }
- main_procinfo.generate_code;
- main_procinfo.resetprocdef;
- release_main_proc(main_procinfo);
- if assigned(init_procinfo) then
- begin
- { initialization can be implicit only }
- current_module.flags:=current_module.flags or uf_init;
- init_procinfo.code:=cnodeutils.wrap_proc_body(init_procinfo.procdef,init_procinfo.code);
- init_procinfo.generate_code;
- init_procinfo.resetprocdef;
- release_main_proc(init_procinfo);
- end;
- if assigned(finalize_procinfo) then
- begin
- if force_init_final or
- cnodeutils.force_init or
- not(has_no_code(finalize_procinfo.code)) then
- begin
- finalize_procinfo.code:=cnodeutils.wrap_proc_body(finalize_procinfo.procdef,finalize_procinfo.code);
- finalize_procinfo.generate_code;
- current_module.flags:=current_module.flags or uf_finalize;
- end;
- finalize_procinfo.resetprocdef;
- release_main_proc(finalize_procinfo);
- end;
- symtablestack.pop(current_module.localsymtable);
- { consume the last point }
- consume(_POINT);
- { reset wpo flags for all defs }
- reset_all_defs;
- if (Errorcount=0) then
- begin
- { test static symtable }
- tstoredsymtable(current_module.localsymtable).allsymbolsused;
- tstoredsymtable(current_module.localsymtable).allprivatesused;
- tstoredsymtable(current_module.localsymtable).check_forwards;
- current_module.allunitsused;
- end;
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- exit;
- end;
- { remove all unused units, this happens when units are removed
- from the uses clause in the source and the ppu was already being loaded }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- hp2:=hp;
- hp:=tmodule(hp.next);
- if hp2.is_unit and
- not assigned(hp2.globalsymtable) then
- begin
- loaded_units.remove(hp2);
- unloaded_units.concat(hp2);
- end;
- end;
- { do we need to add the variants unit? }
- maybeloadvariantsunit;
- { Now that everything has been compiled we know if we need resource
- support. If not, remove the unit. }
- resources_used:=MaybeRemoveResUnit;
- linker.initsysinitunitname;
- if target_info.system in systems_internal_sysinit then
- begin
- { add start/halt unit }
- sysinitmod:=AddUnit(linker.sysinitunit);
- end
- else
- sysinitmod:=nil;
- {$ifdef arm}
- { Insert .pdata section for arm-wince.
- It is needed for exception handling. }
- if target_info.system in [system_arm_wince] then
- InsertPData;
- {$endif arm}
- cnodeutils.InsertThreadvars;
- { generate rtti/init tables }
- write_persistent_type_info(current_module.localsymtable,false);
- { if an Objective-C module, generate rtti and module info }
- MaybeGenerateObjectiveCImageInfo(nil,current_module.localsymtable);
- { generate debuginfo }
- if (cs_debuginfo in current_settings.moduleswitches) then
- current_debuginfo.inserttypeinfo;
- if islibrary or (target_info.system in systems_unit_program_exports) then
- exportlib.generatelib;
- { Reference all DEBUGINFO sections from the main .fpc section }
- if (cs_debuginfo in current_settings.moduleswitches) then
- current_debuginfo.referencesections(current_asmdata.asmlists[al_procedures]);
- { Resource strings }
- GenerateResourceStrings;
- { Windows widestring needing initialization }
- cnodeutils.InsertWideInits;
- { Resourcestring references (const foo:string=someresourcestring) }
- cnodeutils.InsertResStrInits;
- { insert Tables and StackLength }
- cnodeutils.InsertInitFinalTable;
- cnodeutils.InsertThreadvarTablesTable;
- cnodeutils.InsertResourceTablesTable;
- cnodeutils.InsertWideInitsTablesTable;
- cnodeutils.InsertResStrTablesTable;
- cnodeutils.InsertMemorySizes;
- { Insert symbol to resource info }
- cnodeutils.InsertResourceInfo(resources_used);
- { create callframe info }
- create_dwarf_frame;
- { create import library for all packages }
- if packagelist.count>0 then
- createimportlibfromexternals;
- { generate imports }
- if current_module.ImportLibraryList.Count>0 then
- importlib.generatelib;
- { insert own objectfile }
- insertobjectfile;
- { assemble and link }
- create_objectfile;
- { We might need the symbols info if not using
- the default do_extractsymbolinfo
- which is a dummy function PM }
- needsymbolinfo:=
- (do_extractsymbolinfo<>@def_extractsymbolinfo) or
- ((current_settings.genwpoptimizerswitches*WPOptimizationsNeedingAllUnitInfo)<>[]);
- { release all local symtables that are not needed anymore }
- if (not needsymbolinfo) then
- free_localsymtables(current_module.localsymtable);
- { leave when we got an error }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- exit;
- end;
- if (not current_module.is_unit) then
- begin
- { create the executable when we are at level 1 }
- if (compile_level=1) then
- begin
- { create global resource file by collecting all resource files }
- CollectResourceFiles;
- { write .def file }
- if (cs_link_deffile in current_settings.globalswitches) then
- deffile.writefile;
- { link SysInit (if any) first, to have behavior consistent with
- assembler startup files }
- if assigned(sysinitmod) then
- linker.AddModuleFiles(sysinitmod);
- { Does any unit use checkpointer function }
- program_uses_checkpointer:=false;
- { insert all .o files from all loaded units and
- unload the units, we don't need them anymore.
- Keep the current_module because that is still needed }
- hp:=tmodule(loaded_units.first);
- while assigned(hp) do
- begin
- if (hp<>sysinitmod) and (hp.flags and uf_in_library=0) then
- begin
- linker.AddModuleFiles(hp);
- if (hp.flags and uf_checkpointer_called)<>0 then
- program_uses_checkpointer:=true;
- end;
- hp2:=tmodule(hp.next);
- if assigned(hp.package) then
- add_package_unit_ref(hp.package);
- if (hp<>current_module) and
- (not needsymbolinfo) then
- begin
- loaded_units.remove(hp);
- hp.free;
- end;
- hp:=hp2;
- end;
- { free also unneeded units we didn't free before }
- if not needsymbolinfo then
- unloaded_units.Clear;
- { Does any unit use checkpointer function }
- if program_uses_checkpointer then
- Message1(link_w_program_uses_checkpointer,current_module.modulename^);
- { add all directly used packages as libraries }
- add_package_libs(linker);
- { finally we can create an executable }
- if current_module.islibrary then
- linker.MakeSharedLibrary
- else
- linker.MakeExecutable;
- { collect all necessary information for whole-program optimization }
- wpoinfomanager.extractwpoinfofromprogram;
- end;
- { Give Fatal with error count for linker errors }
- if (Errorcount>0) and not status.skip_error then
- begin
- Message1(unit_f_errors_in_unit,tostr(Errorcount));
- status.skip_error:=true;
- end;
- end;
- end;
- end.
|