* Introduce m_processed

This commit is contained in:
Michaël Van Canneyt 2024-02-07 17:26:19 +01:00 committed by Michael Van Canneyt
parent 546de9f7e7
commit 0bf0f26dd5
4 changed files with 352 additions and 171 deletions

View File

@ -62,7 +62,7 @@ type
// Can we continue processing this module ? If not, firstwaiting contains first module that m is waiting for. // Can we continue processing this module ? If not, firstwaiting contains first module that m is waiting for.
function cancontinue(m : tmodule; checksub : boolean; out firstwaiting: tmodule): boolean; function cancontinue(m : tmodule; checksub : boolean; out firstwaiting: tmodule): boolean;
// Overload of cancontinue, based on task. // Overload of cancontinue, based on task.
function cancontinue(t: ttask_list; out firstwaiting: tmodule): boolean; inline function cancontinue(t: ttask_list; out firstwaiting: tmodule): boolean; inline;
// Continue processing this module. Return true if the module is done and can be removed. // Continue processing this module. Return true if the module is done and can be removed.
function continue(t : ttask_list): Boolean; function continue(t : ttask_list): Boolean;
// process the queue. Note that while processing the queue, elements will be added. // process the queue. Note that while processing the queue, elements will be added.

View File

@ -69,7 +69,8 @@ interface
function openppustream(strm:TCStream):boolean; function openppustream(strm:TCStream):boolean;
procedure getppucrc; procedure getppucrc;
procedure writeppu; procedure writeppu;
procedure loadppu(from_module : tmodule); function loadppu(from_module : tmodule) : boolean;
procedure post_load_or_compile(second_time: boolean);
procedure discardppu; procedure discardppu;
function needrecompile:boolean; function needrecompile:boolean;
procedure setdefgeneration; procedure setdefgeneration;
@ -87,7 +88,6 @@ interface
function check_loadfrompackage: boolean; function check_loadfrompackage: boolean;
procedure check_reload(from_module: tmodule; var do_load: boolean); procedure check_reload(from_module: tmodule; var do_load: boolean);
function openppu(ppufiletime:longint):boolean; function openppu(ppufiletime:longint):boolean;
procedure post_load_or_compile(second_time: boolean);
procedure prepare_second_load(from_module: tmodule); procedure prepare_second_load(from_module: tmodule);
procedure recompile_from_sources(from_module: tmodule); procedure recompile_from_sources(from_module: tmodule);
function search_unit_files(loaded_from : tmodule; onlysource:boolean):boolean; function search_unit_files(loaded_from : tmodule; onlysource:boolean):boolean;
@ -132,7 +132,7 @@ interface
{$ENDIF} {$ENDIF}
end; end;
function registerunit(callermodule:tmodule;const s : TIDString;const fn:string) : tppumodule; function registerunit(callermodule:tmodule;const s : TIDString;const fn:string; out is_new:boolean) : tppumodule;
implementation implementation
@ -1306,6 +1306,8 @@ var
indchecksum, indchecksum,
intfchecksum, intfchecksum,
checksum : cardinal; checksum : cardinal;
isnew : boolean;
begin begin
while not ppufile.endofentry do while not ppufile.endofentry do
begin begin
@ -1315,7 +1317,10 @@ var
indchecksum:=cardinal(ppufile.getlongint); indchecksum:=cardinal(ppufile.getlongint);
{ set the state of this unit before registering, this is { set the state of this unit before registering, this is
needed for a correct circular dependency check } needed for a correct circular dependency check }
hp:=registerunit(self,hs,''); hp:=registerunit(self,hs,'',isnew);
if isnew then
usedunits.Concat(tused_unit.create(hp,in_interface,true,nil));
pu:=addusedunit(hp,false,nil); pu:=addusedunit(hp,false,nil);
pu.checksum:=checksum; pu.checksum:=checksum;
pu.interface_checksum:=intfchecksum; pu.interface_checksum:=intfchecksum;
@ -1940,7 +1945,7 @@ var
begin begin
tppumodule(pu.u).loadppu(self); tppumodule(pu.u).loadppu(self);
{ if this unit is compiled we can stop } { if this unit is compiled we can stop }
if state=ms_compiled then if state in [ms_compiled,ms_processed] then
exit; exit;
{ add this unit to the dependencies } { add this unit to the dependencies }
pu.u.adddependency(self,true); pu.u.adddependency(self,true);
@ -2248,10 +2253,10 @@ var
flagdependent(from_module); flagdependent(from_module);
{ Reset the module } { Reset the module }
reset; reset;
{ compile this module } is_reset:=false;
{ mark this module for recompilation }
if not (state in [ms_compile]) then if not (state in [ms_compile]) then
state:=ms_compile; state:=ms_compile;
compile_module(self);
setdefgeneration; setdefgeneration;
end; end;
@ -2267,9 +2272,7 @@ var
{ for a second_time recompile reload all dependent units, { for a second_time recompile reload all dependent units,
for a first time compile register the unit _once_ } for a first time compile register the unit _once_ }
if second_time then if second_time then
reload_flagged_units reload_flagged_units;
else
usedunits.concat(tused_unit.create(self,true,false,nil));
{ reopen the old module } { reopen the old module }
{$ifdef SHORT_ON_FILE_HANDLES} {$ifdef SHORT_ON_FILE_HANDLES}
@ -2277,9 +2280,10 @@ var
assigned(tppumodule(old_current_module).ppufile) then assigned(tppumodule(old_current_module).ppufile) then
tppumodule(old_current_module).ppufile.tempopen; tppumodule(old_current_module).ppufile.tempopen;
{$endif SHORT_ON_FILE_HANDLES} {$endif SHORT_ON_FILE_HANDLES}
state:=ms_processed;
end; end;
procedure tppumodule.loadppu(from_module : tmodule); function tppumodule.loadppu(from_module : tmodule) : boolean;
const const
ImplIntf : array[boolean] of string[15]=('implementation','interface'); ImplIntf : array[boolean] of string[15]=('implementation','interface');
var var
@ -2287,6 +2291,7 @@ var
second_time : boolean; second_time : boolean;
begin begin
Result:=false;
Message3(unit_u_load_unit,from_module.modulename^, Message3(unit_u_load_unit,from_module.modulename^,
ImplIntf[from_module.in_interface], ImplIntf[from_module.in_interface],
modulename^); modulename^);
@ -2295,7 +2300,7 @@ var
we must reload when the do_reload flag is set } we must reload when the do_reload flag is set }
if (not do_reload) and if (not do_reload) and
assigned(globalsymtable) then assigned(globalsymtable) then
exit; exit(True);
{ reset } { reset }
do_load:=true; do_load:=true;
@ -2311,7 +2316,7 @@ var
begin begin
// No need to do anything, restore situation and exit. // No need to do anything, restore situation and exit.
set_current_module(from_module); set_current_module(from_module);
exit; exit(state=ms_compiled);
end; end;
{ loading the unit for a second time? } { loading the unit for a second time? }
@ -2322,6 +2327,7 @@ var
second_time:=true; second_time:=true;
prepare_second_load(from_module); prepare_second_load(from_module);
end; end;
{ close old_current_ppu on system that are { close old_current_ppu on system that are
short on file handles like DOS PM } short on file handles like DOS PM }
{$ifdef SHORT_ON_FILE_HANDLES} {$ifdef SHORT_ON_FILE_HANDLES}
@ -2341,7 +2347,14 @@ var
else else
state:=ms_compiled; state:=ms_compiled;
post_load_or_compile(second_time); Result:=(state=ms_compiled);
// We cannot do this here, the order is all messed up...
// if not second_time then
// usedunits.concat(tused_unit.create(self,true,false,nil));
if result then
post_load_or_compile(second_time);
{ we are back, restore current_module } { we are back, restore current_module }
set_current_module(from_module); set_current_module(from_module);
@ -2362,7 +2375,7 @@ var
*****************************************************************************} *****************************************************************************}
function registerunit(callermodule:tmodule;const s : TIDString;const fn:string) : tppumodule; function registerunit(callermodule:tmodule;const s : TIDString;const fn:string; out is_new:boolean) : tppumodule;
function FindCycle(aFile, SearchFor: TModule; var Cycle: TFPList): boolean; function FindCycle(aFile, SearchFor: TModule; var Cycle: TFPList): boolean;
@ -2428,13 +2441,12 @@ var
if hp.is_unit then if hp.is_unit then
begin begin
{ both units in interface ? } { both units in interface ? }
if hp.in_interface and callermodule.usesmodule_in_interface(hp) then if hp.in_interface and callermodule.in_interface then
begin begin
{ check for a cycle } { check for a cycle }
Cycle:=TFPList.Create; Cycle:=TFPList.Create;
try try
HaveCycle:=FindCycle(CallerModule,hp,Cycle); HaveCycle:=FindCycle(CallerModule,hp,Cycle);
Writeln('Done cycle check, have cycle: ',HaveCycle);
if HaveCycle then if HaveCycle then
begin begin
{$IFDEF DEBUGCYCLE} {$IFDEF DEBUGCYCLE}
@ -2463,7 +2475,8 @@ var
end; end;
{ the unit is not in the loaded units, { the unit is not in the loaded units,
we create an entry and register the unit } we create an entry and register the unit }
if not assigned(hp) then is_new:=not assigned(hp);
if is_new then
begin begin
Message1(unit_u_registering_new_unit,ups); Message1(unit_u_registering_new_unit,ups);
hp:=tppumodule.create(callermodule,s,fn,true); hp:=tppumodule.create(callermodule,s,fn,true);

View File

@ -269,7 +269,7 @@ uses
if hmodule=current_module then if hmodule=current_module then
exit; exit;
if hmodule.state<>ms_compiled then if not (hmodule.state in [ms_compiled,ms_processed]) then
begin begin
{$ifdef DEBUG_UNITWAITING} {$ifdef DEBUG_UNITWAITING}
Writeln('Unit ', current_module.modulename^, Writeln('Unit ', current_module.modulename^,

View File

@ -30,9 +30,9 @@ uses fmodule;
function proc_unit(curr: tmodule):boolean; function proc_unit(curr: tmodule):boolean;
function parse_unit_interface_declarations(curr : tmodule) : boolean; function parse_unit_interface_declarations(curr : tmodule) : boolean;
function proc_unit_implementation(curr: tmodule):boolean; function proc_unit_implementation(curr: tmodule):boolean;
procedure proc_package(curr: tmodule); function proc_package(curr: tmodule) : boolean;
procedure proc_program(curr: tmodule; islibrary : boolean); function proc_program(curr: tmodule; islibrary : boolean) : boolean;
procedure proc_program_declarations(curr : tmodule; islibrary : boolean); function proc_program_declarations(curr : tmodule; islibrary : boolean) : boolean;
implementation implementation
@ -52,6 +52,7 @@ implementation
pkgutil, pkgutil,
wpobase, wpobase,
scanner,pbase,pexpr,psystem,psub,pgenutil,pparautl,ncgvmt,ncgrtti, scanner,pbase,pexpr,psystem,psub,pgenutil,pparautl,ncgvmt,ncgrtti,
ctask,
cpuinfo; cpuinfo;
@ -186,17 +187,23 @@ implementation
var var
hp : tppumodule; hp : tppumodule;
unitsym : tunitsym; unitsym : tunitsym;
isnew,load_ok : boolean;
begin begin
{ load unit } { load unit }
hp:=registerunit(curr,s,''); hp:=registerunit(curr,s,'',isnew);
hp.loadppu(curr); if isnew then
usedunits.concat(tused_unit.create(hp,true,addasused,nil));
load_ok:=hp.loadppu(curr);
hp.adddependency(curr,curr.in_interface); hp.adddependency(curr,curr.in_interface);
if not load_ok then
{ We must schedule a compile. }
task_handler.addmodule(hp);
{ add to symtable stack } { add to symtable stack }
symtablestack.push(hp.globalsymtable); symtablestack.push(hp.globalsymtable);
if (m_mac in current_settings.modeswitches) and if (m_mac in current_settings.modeswitches) and
assigned(hp.globalmacrosymtable) then assigned(hp.globalmacrosymtable) then
macrosymtablestack.push(hp.globalmacrosymtable); macrosymtablestack.push(hp.globalmacrosymtable);
{ insert unitsym } { insert unitsym }
unitsym:=cunitsym.create(hp.modulename^,hp); unitsym:=cunitsym.create(hp.modulename^,hp);
inc(unitsym.refs); inc(unitsym.refs);
@ -214,11 +221,12 @@ implementation
end; end;
procedure maybeloadvariantsunit(curr : tmodule); function maybeloadvariantsunit(curr : tmodule) : boolean;
var var
hp : tmodule; hp : tmodule;
addsystemnamespace : Boolean; addsystemnamespace : Boolean;
begin begin
result:=true;
{ Do we need the variants unit? Skip this { Do we need the variants unit? Skip this
for VarUtils unit for bootstrapping } for VarUtils unit for bootstrapping }
if not(mf_uses_variants in curr.moduleflags) or if not(mf_uses_variants in curr.moduleflags) or
@ -238,7 +246,7 @@ implementation
addsystemnamespace:=namespacelist.Find('System')=Nil; addsystemnamespace:=namespacelist.Find('System')=Nil;
if addsystemnamespace then if addsystemnamespace then
namespacelist.concat('System'); namespacelist.concat('System');
AddUnit(curr,'variants'); result:=AddUnit(curr,'variants').state in [ms_compiled,ms_processed];
if addsystemnamespace then if addsystemnamespace then
namespacelist.Remove('System'); namespacelist.Remove('System');
end; end;
@ -288,6 +296,17 @@ implementation
{ remove the tused_unit } { remove the tused_unit }
usedunits.Remove(uu); usedunits.Remove(uu);
uu.Free; uu.Free;
// Remove from local list
uu:=tused_unit(curr.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
internalerror(2024020701);
curr.used_units.Remove(uu);
uu.Free;
{ remove the module } { remove the module }
loaded_units.Remove(hp); loaded_units.Remove(hp);
unloaded_units.Concat(hp); unloaded_units.Concat(hp);
@ -296,11 +315,13 @@ implementation
end; end;
procedure loadsystemunit(curr : tmodule); function loadsystemunit(curr : tmodule) : boolean;
var var
state: tglobalstate; state: tglobalstate;
sys : tmodule;
begin begin
Result:=False;
{ we are going to rebuild the symtablestack, clear it first } { we are going to rebuild the symtablestack, clear it first }
symtablestack.clear; symtablestack.clear;
macrosymtablestack.clear; macrosymtablestack.clear;
@ -324,7 +345,8 @@ implementation
{ insert the system unit, it is allways the first. Load also the { insert the system unit, it is allways the first. Load also the
internal types from the system unit } internal types from the system unit }
AddUnit(curr,'system'); Sys:=AddUnit(curr,'system');
Result:=Assigned(Sys) and (Sys.State in [ms_processed,ms_compiled]);
systemunit:=tglobalsymtable(symtablestack.top); systemunit:=tglobalsymtable(symtablestack.top);
{ load_intern_types resets the scanner... } { load_intern_types resets the scanner... }
@ -348,34 +370,49 @@ implementation
end; end;
procedure loaddefaultunits(curr :tmodule); { Return true if all units were loaded, no recompilation needed. }
function loaddefaultunits(curr :tmodule) : boolean;
Procedure CheckAddUnit(s: string);
var
OK : boolean;
m : TModule;
begin
m:=AddUnit(curr,s,true);
OK:=assigned(m) and (m.state in [ms_processed,ms_compiled]);
Result:=ok and Result;
end;
begin begin
Result:=True;
{ Units only required for main module } { Units only required for main module }
if not(curr.is_unit) then if not(curr.is_unit) then
begin begin
{ Heaptrc unit, load heaptrace before any other units especially objpas } { Heaptrc unit, load heaptrace before any other units especially objpas }
if (cs_use_heaptrc in current_settings.globalswitches) then if (cs_use_heaptrc in current_settings.globalswitches) then
AddUnit(curr,'heaptrc'); CheckAddUnit('heaptrc');
{ Valgrind requires c memory manager } { Valgrind requires c memory manager }
if (cs_gdb_valgrind in current_settings.globalswitches) or if (cs_gdb_valgrind in current_settings.globalswitches) or
(([cs_sanitize_address]*current_settings.moduleswitches)<>[]) then (([cs_sanitize_address]*current_settings.moduleswitches)<>[]) then
AddUnit(curr,'cmem'); CheckAddUnit('cmem');
{ Lineinfo unit } { Lineinfo unit }
if (cs_use_lineinfo in current_settings.globalswitches) then begin if (cs_use_lineinfo in current_settings.globalswitches) then begin
case target_dbg.id of case target_dbg.id of
dbg_stabs: dbg_stabs:
AddUnit(curr,'lineinfo'); CheckAddUnit('lineinfo');
dbg_stabx: dbg_stabx:
AddUnit(curr,'lnfogdb'); CheckAddUnit('lnfogdb');
else else
AddUnit(curr,'lnfodwrf'); CheckAddUnit('lnfodwrf');
end; end;
end; end;
{$ifdef cpufpemu} {$ifdef cpufpemu}
{ Floating point emulation unit? { Floating point emulation unit?
softfpu must be in the system unit anyways (FK) 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 if (cs_fp_emulation in current_settings.moduleswitches) and not(target_info.system in system_wince) then
AddUnit('softfpu'); CheckAddUnit('softfpu');
} }
{$endif cpufpemu} {$endif cpufpemu}
{ Which kind of resource support? { Which kind of resource support?
@ -383,33 +420,33 @@ implementation
otherwise we need it here since it must be loaded quite early } otherwise we need it here since it must be loaded quite early }
if (tf_has_winlike_resources in target_info.flags) then if (tf_has_winlike_resources in target_info.flags) then
if target_res.id=res_ext then if target_res.id=res_ext then
AddUnit(curr,'fpextres') CheckAddUnit('fpextres')
else else
AddUnit(curr,'fpintres'); CheckAddUnit('fpintres');
end end
else if (cs_checkpointer in current_settings.localswitches) then else if (cs_checkpointer in current_settings.localswitches) then
AddUnit(curr,'heaptrc'); CheckAddUnit('heaptrc');
{ Objpas unit? } { Objpas unit? }
if m_objpas in current_settings.modeswitches then if m_objpas in current_settings.modeswitches then
AddUnit(curr,'objpas'); CheckAddUnit('objpas');
{ Macpas unit? } { Macpas unit? }
if m_mac in current_settings.modeswitches then if m_mac in current_settings.modeswitches then
AddUnit(curr,'macpas'); CheckAddUnit('macpas');
if m_iso in current_settings.modeswitches then if m_iso in current_settings.modeswitches then
AddUnit(curr,'iso7185'); CheckAddUnit('iso7185');
if m_extpas in current_settings.modeswitches then if m_extpas in current_settings.modeswitches then
begin begin
{ basic procedures for Extended Pascal are for now provided by the iso unit } { basic procedures for Extended Pascal are for now provided by the iso unit }
AddUnit(curr,'iso7185'); CheckAddUnit('iso7185');
AddUnit(curr,'extpas'); CheckAddUnit('extpas');
end; end;
{ blocks support? } { blocks support? }
if m_blocks in current_settings.modeswitches then if m_blocks in current_settings.modeswitches then
AddUnit(curr,'blockrtl'); CheckAddUnit('blockrtl');
{ Determine char size. } { Determine char size. }
@ -417,35 +454,35 @@ implementation
if not is_systemunit_unicode then if not is_systemunit_unicode then
begin begin
if m_default_unicodestring in current_settings.modeswitches then if m_default_unicodestring in current_settings.modeswitches then
AddUnit(curr,'uuchar'); // redefines char as widechar CheckAddUnit('uuchar'); // redefines char as widechar
end end
else else
begin begin
// Unicode RTL // Unicode RTL
if not (m_default_ansistring in current_settings.modeswitches) then if not (m_default_ansistring in current_settings.modeswitches) then
if not (curr.modulename^<>'UACHAR') then if not (curr.modulename^<>'UACHAR') then
AddUnit(curr,'uachar'); // redefines char as ansichar CheckAddUnit('uachar'); // redefines char as ansichar
end; end;
{ Objective-C support unit? } { Objective-C support unit? }
if (m_objectivec1 in current_settings.modeswitches) then if (m_objectivec1 in current_settings.modeswitches) then
begin begin
{ interface to Objective-C run time } { interface to Objective-C run time }
AddUnit(curr,'objc'); CheckAddUnit('objc');
loadobjctypes; loadobjctypes;
{ NSObject } { NSObject }
if not(curr.is_unit) or if not(curr.is_unit) or
(curr.modulename^<>'OBJCBASE') then (curr.modulename^<>'OBJCBASE') then
AddUnit(curr,'objcbase'); CheckAddUnit('objcbase');
end; end;
{ Profile unit? Needed for go32v2 only } { Profile unit? Needed for go32v2 only }
if (cs_profile in current_settings.moduleswitches) and if (cs_profile in current_settings.moduleswitches) and
(target_info.system in [system_i386_go32v2,system_i386_watcom]) then (target_info.system in [system_i386_go32v2,system_i386_watcom]) then
AddUnit(curr,'profile'); CheckAddUnit('profile');
if (cs_load_fpcylix_unit in current_settings.globalswitches) then if (cs_load_fpcylix_unit in current_settings.globalswitches) then
begin begin
AddUnit(curr,'fpcylix'); CheckAddUnit('fpcylix');
AddUnit(curr,'dynlibs'); CheckAddUnit('dynlibs');
end; end;
{$push} {$push}
{$warn 6018 off} { Unreachable code due to compile time evaluation } {$warn 6018 off} { Unreachable code due to compile time evaluation }
@ -454,27 +491,27 @@ implementation
(current_settings.controllertype<>ct_none) and (current_settings.controllertype<>ct_none) and
(embedded_controllers[current_settings.controllertype].controllerunitstr<>'') and (embedded_controllers[current_settings.controllertype].controllerunitstr<>'') and
(embedded_controllers[current_settings.controllertype].controllerunitstr<>curr.modulename^) then (embedded_controllers[current_settings.controllertype].controllerunitstr<>curr.modulename^) then
AddUnit(curr,embedded_controllers[current_settings.controllertype].controllerunitstr); CheckAddUnit(embedded_controllers[current_settings.controllertype].controllerunitstr);
{$pop} {$pop}
{$ifdef XTENSA} {$ifdef XTENSA}
if not(curr.is_unit) and (target_info.system=system_xtensa_freertos) then if not(curr.is_unit) and (target_info.system=system_xtensa_freertos) then
if (current_settings.controllertype=ct_esp32) then if (current_settings.controllertype=ct_esp32) then
begin begin
if (idf_version>=40100) and (idf_version<40200) then if (idf_version>=40100) and (idf_version<40200) then
AddUnit(curr,'espidf_40100') CheckAddUnit('espidf_40100')
else if (curr,idf_version>=40200) and (idf_version<40400) then else if (curr,idf_version>=40200) and (idf_version<40400) then
AddUnit(curr,'espidf_40200') CheckAddUnit('espidf_40200')
else if idf_version>=40400 then else if idf_version>=40400 then
AddUnit(curr,'espidf_40400') CheckAddUnit('espidf_40400')
else else
Comment(V_Warning, 'Unsupported esp-idf version'); Comment(V_Warning, 'Unsupported esp-idf version');
end end
else if (current_settings.controllertype=ct_esp8266) then else if (current_settings.controllertype=ct_esp8266) then
begin begin
if (idf_version>=30300) and (idf_version<30400) then if (idf_version>=30300) and (idf_version<30400) then
AddUnit(curr,'esp8266rtos_30300') CheckAddUnit('esp8266rtos_30300')
else if idf_version>=30400 then else if idf_version>=30400 then
AddUnit(curr,'esp8266rtos_30400') CheckAddUnit('esp8266rtos_30400')
else else
Comment(V_Warning, 'Unsupported esp-rtos version'); Comment(V_Warning, 'Unsupported esp-rtos version');
end; end;
@ -482,16 +519,31 @@ implementation
end; end;
procedure loadautounits(curr: tmodule); { Return true if all units were loaded, no recompilation needed. }
function loadautounits(curr: tmodule) : boolean;
Procedure CheckAddUnit(s: string);
var
OK : boolean;
m : TModule;
begin
m:=AddUnit(curr,s,true);
OK:=assigned(m) and (m.state in [ms_compiled,ms_processed]);
Result:=ok and Result;
end;
var var
hs,s : string; hs,s : string;
begin begin
Result:=True;
hs:=autoloadunits; hs:=autoloadunits;
repeat repeat
s:=GetToken(hs,','); s:=GetToken(hs,',');
if s='' then if s='' then
break; break;
AddUnit(curr,s); CheckAddUnit(s);
until false; until false;
end; end;
@ -504,6 +556,7 @@ implementation
hp2 : tmodule; hp2 : tmodule;
unitsym : tunitsym; unitsym : tunitsym;
filepos : tfileposinfo; filepos : tfileposinfo;
isnew : boolean;
begin begin
consume(_USES); consume(_USES);
@ -551,7 +604,11 @@ implementation
pu:=tused_unit(pu.next); pu:=tused_unit(pu.next);
end; end;
if not assigned(hp2) then if not assigned(hp2) then
hp2:=registerunit(curr,sorg,fn) begin
hp2:=registerunit(curr,sorg,fn,isnew);
if isnew then
usedunits.concat(tused_unit.create(hp2,curr.in_interface,true,nil));
end
else else
Message1(sym_e_duplicate_id,s); Message1(sym_e_duplicate_id,s);
{ Create unitsym, we need to use the name as specified, we { Create unitsym, we need to use the name as specified, we
@ -574,13 +631,14 @@ implementation
until false; until false;
end; end;
procedure loadunits(curr: tmodule; preservest:tsymtable; frominterface : boolean); function loadunits(curr: tmodule; frominterface : boolean) : boolean;
var var
s,sorg : ansistring; s : ansistring;
pu,pu2 : tused_unit; pu : tused_unit;
hp2 : tmodule;
state: tglobalstate; state: tglobalstate;
isLoaded : Boolean;
mwait : tmodule;
procedure restorestate; procedure restorestate;
@ -596,7 +654,8 @@ implementation
end; end;
begin begin
parseusesclause(curr); Result:=true;
mwait:=nil;
current_scanner.tempcloseinputfile; current_scanner.tempcloseinputfile;
state:=tglobalstate.create(true); state:=tglobalstate.create(true);
{ Load the units } { Load the units }
@ -606,71 +665,125 @@ implementation
{ Only load the units that are in the current { Only load the units that are in the current
(interface/implementation) uses clause } (interface/implementation) uses clause }
if pu.in_uses and if pu.in_uses and
(pu.in_interface=curr.in_interface) then (pu.in_interface=frominterface) then
begin begin
tppumodule(pu.u).loadppu(curr); if (pu.u.state in [ms_processed, ms_compiled,ms_compiling_waitimpl]) then
{ is our module compiled? then we can stop } isLoaded:=true
if curr.state=ms_compiled then else if (pu.u.state=ms_registered) then
// try to load
isLoaded:=tppumodule(pu.u).loadppu(curr)
else
isLoaded:=False;
isLoaded:=IsLoaded and not pu.u.is_reset;
if not IsLoaded then
begin begin
Restorestate; if mwait=nil then
exit; mwait:=pu.u;
// In case of is_reset, the task handler will discard the state if the module was already there
task_handler.addmodule(pu.u);
end;
Result:=Result and IsLoaded;
{ is our module compiled? then we can stop }
if curr.state in [ms_compiled,ms_processed] then
begin
Restorestate;
exit;
end; end;
{ add this unit to the dependencies } { add this unit to the dependencies }
pu.u.adddependency(curr,frominterface); pu.u.adddependency(curr,frominterface);
{ 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(curr.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(curr.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 } { check hints }
pu.check_hints; pu.check_hints;
end; end;
pu:=tused_unit(pu.next); pu:=tused_unit(pu.next);
end; end;
Restorestate; Restorestate;
end; end;
{
Connect loaded units: check crc and add to symbol tables.
this can only be called after all units were actually loaded!
}
procedure connect_loaded_units(_module : tmodule; preservest:tsymtable);
var
pu : tused_unit;
sorg : ansistring;
unitsymtable: tabstractunitsymtable;
begin
// writeln(_module.get_modulename,': Connecting units');
pu:=tused_unit(_module.used_units.first);
while assigned(pu) do
begin
{
Writeln('Connect : ',Assigned(_module.modulename), ' ', assigned(pu.u), ' ' ,assigned(pu.u.modulename));
if assigned(pu.u) then
begin
if assigned(pu.u.modulename) then
Writeln(_module.modulename^,': Examining connect of file ',pu._fn,' (',pu.u.modulename^,')')
else
Writeln(_module.modulename^,': Examining connect of file ',pu._fn);
end
else
Writeln(_module.modulename^,': Examining unit without module... ');
}
if not (pu.in_uses and
(pu.in_interface=_module.in_interface)) then
begin
// writeln('Must not connect ',pu.u.modulename^,' (pu.in_interface: ',pu.in_interface,' <> module.in_interface',_module.in_interface,')');
end
else
begin
// writeln('Must connect ',pu.u.modulename^,'(sym: ',pu.unitsym.realname,')');
{ 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;
{ 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;
{
Add the unit symbol in the current symtable.
localsymtable will be nil after the interface uses clause is parsed and the local symtable
is moved to the global.
}
if assigned(_module.localsymtable) then
unitsymtable:=tabstractunitsymtable(_module.localsymtable)
else
unitsymtable:=tabstractunitsymtable(_module.globalsymtable);
// Writeln('Adding used unit sym ',pu.unitsym.realName,' to table ',unitsymtable.get_name);
unitsymtable.insertunit(pu.unitsym);
{ add to symtable stack }
// Writeln('Adding used unit symtable ',pu.u.globalsymtable.name^,' (',pu.u.globalsymtable.DefList.Count, ' defs) to 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);
end;
pu:=tused_unit(pu.next);
end;
// writeln(_module.get_modulename,': Done Connecting units');
end;
procedure reset_all_defs(curr: tmodule); procedure reset_all_defs(curr: tmodule);
begin begin
@ -949,15 +1062,20 @@ type
finalize_procinfo : tcgprocinfo; finalize_procinfo : tcgprocinfo;
i,j : integer; i,j : integer;
finishstate:pfinishstate; finishstate:pfinishstate;
globalstate:tglobalstate;
begin begin
if (curr.modulename^='OGBASE') then
Writeln('Here');
result:=true; result:=true;
init_procinfo:=nil; init_procinfo:=nil;
finalize_procinfo:=nil; finalize_procinfo:=nil;
finishstate:=nil; finishstate:=nil;
globalstate:=nil;
set_current_module(curr);
{ We get here only after used modules were loaded }
connect_loaded_units(curr,curr.globalsymtable);
{ All units are read, now give them a number } { All units are read, now give them a number }
curr.updatemaps; curr.updatemaps;
@ -1010,32 +1128,43 @@ type
if result then if result then
finish_unit(curr,true) finish_unit(curr,true)
else
begin
{ save the current state, so the parsing can continue where we left
of here }
globalstate:=tglobalstate.create(true);
end;
end; end;
function parse_unit_interface_declarations(curr : tmodule) : boolean; function parse_unit_interface_declarations(curr : tmodule) : boolean;
begin begin
result:=true; result:=true;
{ create whole program optimisation information (may already be set_current_module(curr);
updated in the interface, e.g., in case of classrefdef typed
constants } { update the symtable }
curr.wpoinfo:=tunitwpoinfo.create; connect_loaded_units(curr,nil);
{ We must do this again, because units can have been added to the list while another task was being handled }
curr.updatemaps;
{ consume the semicolon after maps have been updated else conditional compiling expressions
might cause internal errors, see tw8611 }
if curr.consume_semicolon_after_uses then
consume(_SEMICOLON);
{ now push our own symtable }
symtablestack.push(curr.globalsymtable);
{ Dump stack
Write(curr.modulename^);
symtablestack.dump;
}
{ ... parse the declarations } { ... parse the declarations }
Message1(parser_u_parsing_interface,curr.realmodulename^); Message1(parser_u_parsing_interface,curr.realmodulename^);
symtablestack.push(curr.globalsymtable);
{$ifdef jvm} {$ifdef jvm}
{ fake classdef to represent the class corresponding to the unit } { fake classdef to represent the class corresponding to the unit }
addmoduleclass; addmoduleclass;
{$endif} {$endif}
read_interface_declarations; read_interface_declarations;
{ Export macros defined in the interface for macpas. The macros { Export macros defined in the interface for macpas. The macros
are put in the globalmacrosymtable that will only be used by other are put in the globalmacrosymtable that will only be used by other
units. The current unit continues to use the localmacrosymtable } units. The current unit continues to use the localmacrosymtable }
@ -1082,6 +1211,7 @@ type
{ create static symbol table } { create static symbol table }
curr.localsymtable:=tstaticsymtable.create(curr.modulename^,curr.moduleid); curr.localsymtable:=tstaticsymtable.create(curr.modulename^,curr.moduleid);
{ Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it } { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
maybe_load_got; maybe_load_got;
if not curr.interface_only then if not curr.interface_only then
@ -1091,17 +1221,23 @@ type
{ Read the implementation units } { Read the implementation units }
if token=_USES then if token=_USES then
begin begin
loadunits(curr,curr.globalsymtable,false); parseusesclause(curr);
consume(_SEMICOLON); if not loadunits(curr,false) then
curr.state:=ms_compiling_waitimpl;
consume(_SEMICOLON);
end; end;
end; end;
if curr.state=ms_compiled then if curr.state in [ms_compiled,ms_processed] then
begin begin
symtablestack.pop(curr.globalsymtable); // Writeln('Popping global symtable ?');
exit(true); symtablestack.pop(curr.globalsymtable);
end; end;
result:=proc_unit_implementation(curr);
{ Can we continue compiling ? }
result:=curr.state<>ms_compiling_waitimpl;
if result then
result:=proc_unit_implementation(curr)
end; end;
function proc_unit(curr: tmodule):boolean; function proc_unit(curr: tmodule):boolean;
@ -1112,6 +1248,7 @@ type
unitname8 : string[8]; unitname8 : string[8];
consume_semicolon_after_uses:boolean; consume_semicolon_after_uses:boolean;
feature : tfeature; feature : tfeature;
load_ok : boolean;
begin begin
result:=true; result:=true;
@ -1193,7 +1330,7 @@ type
{ load default system unit, it must be loaded before interface is parsed { 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 } else we cannot use e.g. feature switches before the next real token }
loadsystemunit(curr); load_ok:=loadsystemunit(curr);
{ system unit is loaded, now insert feature defines } { system unit is loaded, now insert feature defines }
for feature:=low(tfeature) to high(tfeature) do for feature:=low(tfeature) to high(tfeature) do
@ -1222,7 +1359,7 @@ type
{ load default units, like language mode units } { load default units, like language mode units }
if not(cs_compilesystem in current_settings.moduleswitches) then if not(cs_compilesystem in current_settings.moduleswitches) then
loaddefaultunits(curr); load_ok:=loaddefaultunits(curr) and load_ok;
{ insert qualifier for the system unit (allows system.writeln) } { insert qualifier for the system unit (allows system.writeln) }
if not(cs_compilesystem in current_settings.moduleswitches) and if not(cs_compilesystem in current_settings.moduleswitches) and
@ -1233,9 +1370,10 @@ type
curr.Loadlocalnamespacelist curr.Loadlocalnamespacelist
else else
current_namespacelist:=Nil; current_namespacelist:=Nil;
loadunits(curr, nil,true); parseusesclause(curr);
load_ok:=loadunits(curr,true) and load_ok;
{ has it been compiled at a higher level ?} { has it been compiled at a higher level ?}
if curr.state=ms_compiled then if curr.state in [ms_compiled,ms_processed] then
begin begin
Message1(parser_u_already_compiled,curr.realmodulename^); Message1(parser_u_already_compiled,curr.realmodulename^);
exit; exit;
@ -1246,22 +1384,27 @@ type
else else
consume_semicolon_after_uses:=false; consume_semicolon_after_uses:=false;
{ we need to store this in case compilation is transferred to another unit }
curr.consume_semicolon_after_uses:=consume_semicolon_after_uses;
{ move the global symtable from the temporary local to global } { move the global symtable from the temporary local to global }
curr.globalsymtable:=curr.localsymtable; current_module.globalsymtable:=current_module.localsymtable;
curr.localsymtable:=nil; current_module.localsymtable:=nil;
{ number all units, so we know if a unit is used by this unit or { Now we check if we can continue. }
needs to be added implicitly }
curr.updatemaps;
{ consume the semicolon after maps have been updated else conditional compiling expressions if not load_ok then
might cause internal errors, see tw8611 } curr.state:=ms_compiling_waitintf;
if consume_semicolon_after_uses then { create whole program optimisation information (may already be
consume(_SEMICOLON); updated in the interface, e.g., in case of classrefdef typed
constants }
result:=parse_unit_interface_declarations(curr); curr.wpoinfo:=tunitwpoinfo.create;
{ Can we continue compiling ? }
result:=curr.state<>ms_compiling_waitintf;
if result then
result:=parse_unit_interface_declarations(curr);
end; end;
procedure finish_unit(module:tmodule;immediate:boolean); procedure finish_unit(module:tmodule;immediate:boolean);
@ -1626,7 +1769,7 @@ type
end; end;
procedure proc_package(curr: tmodule); function proc_package(curr: tmodule) : boolean;
var var
main_file : tinputfile; main_file : tinputfile;
hp,hp2 : tmodule; hp,hp2 : tmodule;
@ -1638,6 +1781,7 @@ type
pentry: ppackageentry; pentry: ppackageentry;
feature : tfeature; feature : tfeature;
begin begin
Result:=True;
Status.IsPackage:=true; Status.IsPackage:=true;
Status.IsExe:=true; Status.IsExe:=true;
parse_only:=false; parse_only:=false;
@ -2234,7 +2378,7 @@ type
cnodeutils.InsertResStrInits; cnodeutils.InsertResStrInits;
{ insert Tables and StackLength } { insert Tables and StackLength }
cnodeutils.InsertInitFinalTable; cnodeutils.InsertInitFinalTable(curr);
cnodeutils.InsertThreadvarTablesTable; cnodeutils.InsertThreadvarTablesTable;
cnodeutils.InsertResourceTablesTable; cnodeutils.InsertResourceTablesTable;
cnodeutils.InsertWideInitsTablesTable; cnodeutils.InsertWideInitsTablesTable;
@ -2290,9 +2434,12 @@ type
Message1(unit_f_errors_in_unit,tostr(Errorcount)); Message1(unit_f_errors_in_unit,tostr(Errorcount));
status.skip_error:=true; status.skip_error:=true;
end; end;
curr.state:=ms_processed;
end; end;
procedure proc_program_declarations(curr : tmodule; islibrary : boolean); function proc_program_declarations(curr : tmodule; islibrary : boolean) : boolean;
var var
initpd : tprocdef; initpd : tprocdef;
@ -2302,10 +2449,23 @@ type
force_init_final : boolean; force_init_final : boolean;
begin begin
result:=true;
main_procinfo:=nil; main_procinfo:=nil;
init_procinfo:=nil; init_procinfo:=nil;
finalize_procinfo:=nil; finalize_procinfo:=nil;
set_current_module(curr);
{ All units are read, now give them a number }
curr.updatemaps;
{ consume the semicolon after maps have been updated else conditional compiling expressions
might cause internal errors, see tw8611 }
if curr.consume_semicolon_after_uses then
consume(_SEMICOLON);
connect_loaded_units(curr,nil);
{Insert the name of the main program into the symbol table.} {Insert the name of the main program into the symbol table.}
if curr.realmodulename^<>'' then if curr.realmodulename^<>'' then
tabstractunitsymtable(curr.localsymtable).insertunit(cunitsym.create(curr.realmodulename^,curr)); tabstractunitsymtable(curr.localsymtable).insertunit(cunitsym.create(curr.realmodulename^,curr));
@ -2475,7 +2635,10 @@ type
{ consume the last point } { consume the last point }
consume(_POINT); consume(_POINT);
proc_program_after_parsing(curr,islibrary); proc_program_after_parsing(curr,islibrary);
end; end;
procedure proc_library_header(curr: tmodule); procedure proc_library_header(curr: tmodule);
@ -2573,7 +2736,7 @@ type
{$endif DEBUG_NODE_XML} {$endif DEBUG_NODE_XML}
end; end;
procedure proc_program(curr: tmodule; islibrary : boolean); function proc_program(curr: tmodule; islibrary : boolean) : boolean;
var var
main_file : tinputfile; main_file : tinputfile;
@ -2584,8 +2747,10 @@ type
sc : TProgramParamArray; sc : TProgramParamArray;
i : Longint; i : Longint;
feature : tfeature; feature : tfeature;
load_ok : boolean;
begin begin
result:=true;
Status.IsLibrary:=IsLibrary; Status.IsLibrary:=IsLibrary;
Status.IsPackage:=false; Status.IsPackage:=false;
Status.IsExe:=true; Status.IsExe:=true;
@ -2665,7 +2830,7 @@ type
curr.localsymtable:=tstaticsymtable.create(curr.modulename^,curr.moduleid); curr.localsymtable:=tstaticsymtable.create(curr.modulename^,curr.moduleid);
{ load system unit } { load system unit }
loadsystemunit(curr); load_ok:=loadsystemunit(curr);
{ consume the semicolon now that the system unit is loaded } { consume the semicolon now that the system unit is loaded }
if consume_semicolon_after_loaded then if consume_semicolon_after_loaded then
@ -2680,10 +2845,10 @@ type
def_system_macro('FPC_HAS_FEATURE_'+featurestr[feature]); def_system_macro('FPC_HAS_FEATURE_'+featurestr[feature]);
{ load standard units, e.g objpas,profile unit } { load standard units, e.g objpas,profile unit }
loaddefaultunits(curr); load_ok:=loaddefaultunits(curr) and load_ok;
{ Load units provided on the command line } { Load units provided on the command line }
loadautounits(curr); load_ok:=loadautounits(curr) and load_ok;
{ insert iso program parameters } { insert iso program parameters }
if length(sc)>0 then if length(sc)>0 then
@ -2706,21 +2871,24 @@ type
curr.Loadlocalnamespacelist curr.Loadlocalnamespacelist
else else
current_namespacelist:=Nil; current_namespacelist:=Nil;
loadunits(curr,nil,false); parseusesclause(curr);
load_ok:=loadunits(curr,false) and load_ok;
consume_semicolon_after_uses:=true; consume_semicolon_after_uses:=true;
end end
else else
consume_semicolon_after_uses:=false; consume_semicolon_after_uses:=false;
{ All units are read, now give them a number } Curr.consume_semicolon_after_uses:=consume_semicolon_after_uses;
curr.updatemaps;
{ consume the semicolon after maps have been updated else conditional compiling expressions if not load_ok then
might cause internal errors, see tw8611 } curr.state:=ms_compiling_wait;
if consume_semicolon_after_uses then
consume(_SEMICOLON);
proc_program_declarations(curr,islibrary);
{ Can we continue compiling ? }
result:=curr.state<>ms_compiling_wait;
if result then
result:=proc_program_declarations(curr,islibrary)
end; end;
end. end.