paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 09:19:32 +02:00
Code Issues Packages Projects Releases Wiki Activity
bfd72ad5d5
fpc/compiler/pmodules.pas
peter bfd72ad5d5 * merged changes from 1.0.7 up to 04-11 
- -V option for generating bug report tracing
    - more tracing for option parsing
    - errors for cdecl and high()
    - win32 import stabs
    - win32 records<=8 are returned in eax:edx (turned off by default)
    - heaptrc update
    - more info for temp management in .s file with EXTDEBUG
2002-11-15 01:58:45 +00:00

1589 lines
56 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 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}
{$define New_GDB}
interface
procedure proc_unit;
procedure proc_program(islibrary : boolean);
implementation
uses
globtype,version,systems,tokens,
cutils,cclasses,comphook,
globals,verbose,fmodule,finput,fppu,
symconst,symbase,symtype,symdef,symsym,symtable,
aasmbase,aasmtai,aasmcpu,
cgbase,cpuinfo,
ncgutil,
link,assemble,import,export,gendef,ppu,comprsrc,
cresstr,cpubase,
{$ifdef GDB}
gdb,
{$endif GDB}
scanner,pbase,pexpr,psystem,psub;
procedure create_objectfile;
var
DLLScanner : TDLLScanner;
s : string;
KeepShared : TStringList;
begin
{ try to create import entries from system dlls }
if target_info.DllScanSupported 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:=TStringList.Create;
{ Walk all shared libs }
While not current_module.linkOtherSharedLibs.Empty do
begin
S:=current_module.linkOtherSharedLibs.Getusemask(link_allways);
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(importssection)then
importssection.clear
else
importssection:=taasmoutput.Create;
importlib.generatelib;
end;
{ Readd the not processed files }
while not KeepShared.Empty do
begin
s:=KeepShared.GetFirst;
current_module.linkOtherSharedLibs.add(s,link_allways);
end;
KeepShared.Free;
end;
{ create the .s file and assemble it }
GenerateAsm(false);
{ Also create a smartlinked version ? }
if (cs_create_smart in aktmoduleswitches) then
begin
{ regenerate the importssection for win32 }
if assigned(importssection) and
(target_info.system in [system_i386_win32,system_i386_wdosx]) then
begin
importsSection.clear;
importlib.generatesmartlib;
end;
GenerateAsm(true);
if target_asm.needar 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 (cs_create_smart in aktmoduleswitches) then
begin
current_module.linkunitstaticlibs.add(current_module.staticlibfilename^,link_smart);
current_module.flags:=current_module.flags or uf_smart_linked;
end;
end;
procedure insertsegment;
procedure fixseg(p:TAAsmoutput;sec:TSection);
begin
p.insert(Tai_section.Create(sec));
if (cs_create_smart in aktmoduleswitches) then
p.insert(Tai_cut.Create);
p.concat(Tai_section.Create(sec_none));
end;
begin
{ Insert Ident of the compiler }
if (not (cs_create_smart in aktmoduleswitches))
{$ifndef EXTDEBUG}
and (not current_module.is_unit)
{$endif}
then
begin
{ align the first data }
dataSegment.insert(Tai_align.Create(const_align(32)));
dataSegment.insert(Tai_string.Create('FPC '+full_version_string+
' ['+date_string+'] for '+target_cpu_string+' - '+target_info.shortname));
end;
{ align code segment }
codeSegment.concat(Tai_align.Create(aktalignment.procalign));
{ Insert start and end of sections }
fixseg(codesegment,sec_code);
fixseg(datasegment,sec_data);
fixseg(bsssegment,sec_bss);
{ we should use .rdata section for these two no ? }
{ .rdata is a read only data section (PM) }
fixseg(rttilist,sec_data);
fixseg(consts,sec_data);
if assigned(resourcestringlist) then
fixseg(resourcestringlist,sec_data);
{$ifdef GDB}
if assigned(debuglist) then
begin
debugList.insert(Tai_symbol.Createname('gcc2_compiled',0));
debugList.insert(Tai_symbol.Createname('fpc_compiled',0));
fixseg(debuglist,sec_code);
end;
{$endif GDB}
end;
procedure InsertThreadvarTablesTable;
var
hp : tused_unit;
ltvTables : taasmoutput;
count : longint;
begin
ltvTables:=TAAsmOutput.Create;
count:=0;
hp:=tused_unit(usedunits.first);
while assigned(hp) do
begin
If (hp.u.flags and uf_threadvars)=uf_threadvars then
begin
ltvTables.concat(Tai_const_symbol.Createname(hp.u.modulename^+'_$THREADVARLIST'));
inc(count);
end;
hp:=tused_unit(hp.next);
end;
{ Add program threadvars, if any }
If (current_module.flags and uf_threadvars)=uf_threadvars then
begin
ltvTables.concat(Tai_const_symbol.Createname(current_module.modulename^+'_$THREADVARLIST'));
inc(count);
end;
{ TableCount }
ltvTables.insert(Tai_const.Create_32bit(count));
ltvTables.insert(Tai_symbol.Createdataname_global('FPC_THREADVARTABLES',0));
ltvTables.insert(Tai_align.Create(const_align(pointer_size)));
ltvTables.concat(Tai_symbol_end.Createname('FPC_THREADVARTABLES'));
{ insert in data segment }
if (cs_create_smart in aktmoduleswitches) then
dataSegment.concat(Tai_cut.Create);
dataSegment.concatlist(ltvTables);
ltvTables.free;
if count > 0 then
have_local_threadvars := true;
end;
procedure AddToThreadvarList(p:tnamedindexitem;arg:pointer);
var
ltvTable : taasmoutput;
begin
ltvTable:=taasmoutput(arg);
if (tsym(p).typ=varsym) and
(vo_is_thread_var in tvarsym(p).varoptions) then
begin
{ address of threadvar }
ltvTable.concat(tai_const_symbol.createname(tvarsym(p).mangledname));
{ size of threadvar }
ltvTable.concat(tai_const.create_32bit(tvarsym(p).getsize));
end;
end;
procedure InsertThreadvars;
var
ltvTable : TAAsmoutput;
begin
ltvTable:=TAAsmoutput.create;
if assigned(current_module.globalsymtable) then
current_module.globalsymtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}AddToThreadvarList,ltvTable);
current_module.localsymtable.foreach_static({$ifdef FPCPROCVAR}@{$endif}AddToThreadvarList,ltvTable);
if ltvTable.first<>nil then
begin
{ add begin and end of the list }
ltvTable.insert(tai_symbol.createdataname_global(current_module.modulename^+'_$THREADVARLIST',0));
ltvTable.concat(tai_const.create_32bit(0)); { end of list marker }
ltvTable.concat(tai_symbol_end.createname(current_module.modulename^+'_$THREADVARLIST'));
if (cs_create_smart in aktmoduleswitches) then
dataSegment.concat(Tai_cut.Create);
dataSegment.concatlist(ltvTable);
current_module.flags:=current_module.flags or uf_threadvars;
end;
ltvTable.Free;
end;
Procedure InsertResourceTablesTable;
var
hp : tused_unit;
ResourceStringTables : taasmoutput;
count : longint;
begin
ResourceStringTables:=TAAsmOutput.Create;
count:=0;
hp:=tused_unit(usedunits.first);
while assigned(hp) do
begin
If (hp.u.flags and uf_has_resources)=uf_has_resources then
begin
ResourceStringTables.concat(Tai_const_symbol.Createname(hp.u.modulename^+'_RESOURCESTRINGLIST'));
inc(count);
end;
hp:=tused_unit(hp.next);
end;
{ Add program resources, if any }
If ResourceStringList<>Nil then
begin
ResourceStringTables.concat(Tai_const_symbol.Createname(current_module.modulename^+'_RESOURCESTRINGLIST'));
Inc(Count);
end;
{ TableCount }
ResourceStringTables.insert(Tai_const.Create_32bit(count));
ResourceStringTables.insert(Tai_symbol.Createdataname_global('FPC_RESOURCESTRINGTABLES',0));
ResourceStringTables.insert(Tai_align.Create(const_align(4)));
ResourceStringTables.concat(Tai_symbol_end.Createname('FPC_RESOURCESTRINGTABLES'));
{ insert in data segment }
if (cs_create_smart in aktmoduleswitches) then
dataSegment.concat(Tai_cut.Create);
dataSegment.concatlist(ResourceStringTables);
ResourceStringTables.free;
end;
procedure InsertInitFinalTable;
var
hp : tused_unit;
unitinits : taasmoutput;
count : longint;
begin
unitinits:=TAAsmOutput.Create;
count:=0;
hp:=tused_unit(usedunits.first);
while assigned(hp) do
begin
{ call the unit init code and make it external }
if (hp.u.flags and (uf_init or uf_finalize))<>0 then
begin
if (hp.u.flags and uf_init)<>0 then
unitinits.concat(Tai_const_symbol.Createname('INIT$$'+hp.u.modulename^))
else
unitinits.concat(Tai_const.Create_32bit(0));
if (hp.u.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+hp.u.modulename^))
else
unitinits.concat(Tai_const.Create_32bit(0));
inc(count);
end;
hp:=tused_unit(hp.next);
end;
{ Insert initialization/finalization of the program }
if (current_module.flags and (uf_init or uf_finalize))<>0 then
begin
if (current_module.flags and uf_init)<>0 then
unitinits.concat(Tai_const_symbol.Createname('INIT$$'+current_module.modulename^))
else
unitinits.concat(Tai_const.Create_32bit(0));
if (current_module.flags and uf_finalize)<>0 then
unitinits.concat(Tai_const_symbol.Createname('FINALIZE$$'+current_module.modulename^))
else
unitinits.concat(Tai_const.Create_32bit(0));
inc(count);
end;
{ TableCount,InitCount }
unitinits.insert(Tai_const.Create_32bit(0));
unitinits.insert(Tai_const.Create_32bit(count));
unitinits.insert(Tai_symbol.Createdataname_global('INITFINAL',0));
unitinits.insert(Tai_align.Create(const_align(4)));
unitinits.concat(Tai_symbol_end.Createname('INITFINAL'));
{ insert in data segment }
if (cs_create_smart in aktmoduleswitches) then
dataSegment.concat(Tai_cut.Create);
dataSegment.concatlist(unitinits);
unitinits.free;
end;
procedure insertheap;
begin
if (cs_create_smart in aktmoduleswitches) then
begin
bssSegment.concat(Tai_cut.Create);
dataSegment.concat(Tai_cut.Create);
end;
{ On the Macintosh Classic M68k Architecture
The Heap variable is simply a POINTER to the
real HEAP. The HEAP must be set up by the RTL
and must store the pointer in this value.
On OS/2 the heap is also intialized by the RTL. We do
not output a pointer }
case target_info.system of
{$ifdef x86_64}
target_x86_64_linux:
;
{$endif x86_64}
{$ifdef i386}
system_i386_OS2:
;
{$endif i386}
{$ifdef powerpc}
system_powerpc_macos:
;
{$endif powerpc}
{$ifdef alpha}
system_alpha_linux:
;
{$endif alpha}
{$ifdef m68k}
system_m68k_Mac:
bssSegment.concat(Tai_datablock.Create_global('HEAP',4));
system_m68k_PalmOS:
;
{$endif m68k}
{$IFDEF SPARC}
system_SPARC_Linux:
;
{$ENDIF SPARC}
else
begin
bssSegment.concat(Tai_align.Create(var_align(heapsize)));
bssSegment.concat(Tai_datablock.Create_global('HEAP',heapsize));
end;
end;
{$ifdef m68k}
if target_info.system<>system_m68k_PalmOS then
begin
dataSegment.concat(Tai_align.Create(const_align(4)));
dataSegment.concat(Tai_symbol.Createdataname_global('HEAPSIZE',4));
dataSegment.concat(Tai_const.Create_32bit(heapsize));
end;
{$else m68k}
dataSegment.concat(Tai_align.Create(const_align(4)));
dataSegment.concat(Tai_symbol.Createdataname_global('HEAPSIZE',4));
dataSegment.concat(Tai_const.Create_32bit(heapsize));
{$endif m68k}
end;
procedure insertstacklength;
begin
{ stacksize can be specified and is now simulated }
dataSegment.concat(Tai_align.Create(const_align(4)));
dataSegment.concat(Tai_symbol.Createdataname_global('__stklen',4));
dataSegment.concat(Tai_const.Create_32bit(stacksize));
end;
procedure loaddefaultunits;
var
hp : tmodule;
unitsym : tunitsym;
begin
{ are we compiling the system unit? }
if (cs_compilesystem in aktmoduleswitches) then
begin
{ create system defines }
createconstdefs;
{ we don't need to reset anything, it's already done in parser.pas }
exit;
end;
{ insert the system unit, it is allways the first }
hp:=loadunit('System','');
systemunit:=tglobalsymtable(hp.globalsymtable);
{ it's always the first unit }
systemunit.next:=nil;
symtablestack:=systemunit;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('System',systemunit);
inc(unitsym.refs);
refsymtable.insert(unitsym);
{ read default constant definitions }
make_ref:=false;
readconstdefs;
make_ref:=true;
{ Thread support unit? }
if (cs_threading in aktmoduleswitches) then
begin
hp:=loadunit('systhrds','');
tsymtable(hp.globalsymtable).next:=symtablestack;
symtablestack:=hp.globalsymtable;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('Threads',hp.globalsymtable);
inc(unitsym.refs);
refsymtable.insert(unitsym);
end;
{ Objpas unit? }
if m_objpas in aktmodeswitches then
begin
hp:=loadunit('ObjPas','');
tsymtable(hp.globalsymtable).next:=symtablestack;
symtablestack:=hp.globalsymtable;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('ObjPas',hp.globalsymtable);
inc(unitsym.refs);
refsymtable.insert(unitsym);
end;
{ Profile unit? Needed for go32v2 only }
if (cs_profile in aktmoduleswitches) and (target_info.system=system_i386_go32v2) then
begin
hp:=loadunit('Profile','');
tsymtable(hp.globalsymtable).next:=symtablestack;
symtablestack:=hp.globalsymtable;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('Profile',hp.globalsymtable);
inc(unitsym.refs);
refsymtable.insert(unitsym);
end;
{ Units only required for main module }
if not(current_module.is_unit) then
begin
{ Heaptrc unit }
if (cs_gdb_heaptrc in aktglobalswitches) then
begin
hp:=loadunit('HeapTrc','');
tsymtable(hp.globalsymtable).next:=symtablestack;
symtablestack:=hp.globalsymtable;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('HeapTrc',hp.globalsymtable);
inc(unitsym.refs);
refsymtable.insert(unitsym);
end;
{ Lineinfo unit }
if (cs_gdb_lineinfo in aktglobalswitches) then
begin
hp:=loadunit('LineInfo','');
tsymtable(hp.globalsymtable).next:=symtablestack;
symtablestack:=hp.globalsymtable;
{ add to the used units }
current_module.used_units.concat(tused_unit.create(hp,true));
unitsym:=tunitsym.create('LineInfo',hp.globalsymtable);
inc(unitsym.refs);
refsymtable.insert(unitsym);
end;
end;
{ save default symtablestack }
defaultsymtablestack:=symtablestack;
end;
procedure loadunits;
var
s,sorg : stringid;
fn : string;
pu,
hp : tused_unit;
hp2 : tmodule;
hp3 : tsymtable;
oldprocsym:tprocsym;
oldprocdef:tprocdef;
unitsym : tunitsym;
begin
oldprocsym:=aktprocsym;
oldprocdef:=aktprocdef;
consume(_USES);
{$ifdef DEBUG}
test_symtablestack;
{$endif DEBUG}
repeat
s:=pattern;
sorg:=orgpattern;
consume(_ID);
{ support "<unit> in '<file>'" construct, but not for tp7 }
if not(m_tp7 in aktmodeswitches) then
begin
if try_to_consume(_OP_IN) then
fn:=get_stringconst
else
fn:='';
end;
{ Give a warning if objpas is loaded }
if s='OBJPAS' then
Message(parser_w_no_objpas_use_mode);
{ check if the unit is already used }
pu:=tused_unit(current_module.used_units.first);
while assigned(pu) do
begin
if (pu.name^=s) then
break;
pu:=tused_unit(pu.next);
end;
{ avoid uses of itself }
if not assigned(pu) and (s<>current_module.modulename^) then
begin
{ load the unit }
hp2:=loadunit(sorg,fn);
{ the current module uses the unit hp2 }
current_module.used_units.concat(tused_unit.create(hp2,not current_module.in_implementation));
tused_unit(current_module.used_units.last).in_uses:=true;
if current_module.compiled then
exit;
unitsym:=tunitsym.create(sorg,hp2.globalsymtable);
{ never claim about unused unit if
there is init or finalize code PM }
if (hp2.flags and (uf_init or uf_finalize))<>0 then
inc(unitsym.refs);
refsymtable.insert(unitsym);
end
else
Message1(sym_e_duplicate_id,s);
if token=_COMMA then
begin
pattern:='';
consume(_COMMA);
end
else
break;
until false;
consume(_SEMICOLON);
{ set the symtable to systemunit so it gets reorderd correctly }
symtablestack:=defaultsymtablestack;
{ now insert the units in the symtablestack }
hp:=tused_unit(current_module.used_units.first);
while assigned(hp) do
begin
{$IfDef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(cs_gdb_dbx in aktglobalswitches) and
not hp.is_stab_written then
begin
tglobalsymtable(hp.u.globalsymtable).concattypestabto(debuglist);
hp.is_stab_written:=true;
hp.unitid:=tsymtable(hp.u.globalsymtable).unitid;
end;
{$EndIf GDB}
if hp.in_uses then
begin
hp3:=symtablestack;
while assigned(hp3) do
begin
{ insert units only once ! }
if hp.u.globalsymtable=hp3 then
break;
hp3:=hp3.next;
{ unit isn't inserted }
if hp3=nil then
begin
tsymtable(hp.u.globalsymtable).next:=symtablestack;
symtablestack:=tsymtable(hp.u.globalsymtable);
{$ifdef DEBUG}
test_symtablestack;
{$endif DEBUG}
end;
end;
end;
hp:=tused_unit(hp.next);
end;
aktprocsym:=oldprocsym;
aktprocdef:=oldprocdef;
end;
procedure write_gdb_info;
{$IfDef GDB}
var
hp : tused_unit;
begin
if not (cs_debuginfo in aktmoduleswitches) then
exit;
{ now insert the units in the symtablestack }
hp:=tused_unit(current_module.used_units.first);
while assigned(hp) do
begin
if (cs_debuginfo in aktmoduleswitches) and
not hp.is_stab_written then
begin
tglobalsymtable(hp.u.globalsymtable).concattypestabto(debuglist);
hp.is_stab_written:=true;
hp.unitid:=tsymtable(hp.u.globalsymtable).unitid;
end;
hp:=tused_unit(hp.next);
end;
if current_module.in_implementation and
assigned(current_module.localsymtable) then
begin
{ all types }
tstaticsymtable(current_module.localsymtable).concattypestabto(debuglist);
{ and all local symbols}
tstaticsymtable(current_module.localsymtable).concatstabto(debuglist);
end
else if assigned(current_module.globalsymtable) then
begin
{ all types }
tglobalsymtable(current_module.globalsymtable).concattypestabto(debuglist);
{ and all local symbols}
tglobalsymtable(current_module.globalsymtable).concatstabto(debuglist);
end;
if (cs_gdb_dbx in aktglobalswitches) then
begin
debugList.concat(tai_comment.Create(strpnew('EINCL of global '+
tglobalsymtable(current_module.globalsymtable).name^+' has index '+
tostr(tglobalsymtable(current_module.globalsymtable).unitid))));
debugList.concat(Tai_stabs.Create(strpnew('"'+
tglobalsymtable(current_module.globalsymtable).name^+'",'+
tostr(N_EINCL)+',0,0,0')));
tglobalsymtable(current_module.globalsymtable).dbx_count_ok:={true}false;
dbx_counter:=tglobalsymtable(current_module.globalsymtable).prev_dbx_counter;
do_count_dbx:=false;
end;
end;
{$Else GDB}
begin
end;
{$EndIf GDB}
procedure parse_implementation_uses(symt:tsymtable);
begin
if token=_USES then
begin
loadunits;
{$ifdef DEBUG}
test_symtablestack;
{$endif DEBUG}
end;
end;
procedure setupglobalswitches;
begin
{ can't have local browser when no global browser }
if (cs_local_browser in aktmoduleswitches) and
not(cs_browser in aktmoduleswitches) then
exclude(aktmoduleswitches,cs_local_browser);
{ define a symbol in delphi,objfpc,tp,gpc mode }
if (m_delphi in aktmodeswitches) then
current_scanner.def_macro('FPC_DELPHI')
else
if (m_tp7 in aktmodeswitches) then
current_scanner.def_macro('FPC_TP')
else
if (m_objfpc in aktmodeswitches) then
current_scanner.def_macro('FPC_OBJFPC')
else
if (m_gpc in aktmodeswitches) then
current_scanner.def_macro('FPC_GPC');
end;
procedure gen_main_procsym(const name:string;options:tproctypeoption;st:tsymtable);
var
stt : tsymtable;
begin
{Generate a procsym for main}
make_ref:=false;
aktprocsym:=tprocsym.create('$'+name);
{ main are allways used }
inc(aktprocsym.refs);
{Try to insert in in static symtable ! }
stt:=symtablestack;
symtablestack:=st;
aktprocdef:=tprocdef.create;
aktprocsym.addprocdef(aktprocdef);
aktprocdef.procsym:=aktprocsym;
symtablestack:=stt;
aktprocdef.proctypeoption:=options;
aktprocdef.setmangledname(target_info.cprefix+name);
aktprocdef.forwarddef:=false;
make_ref:=true;
{ The localst is a local symtable. Change it into the static
symtable }
aktprocdef.localst.free;
aktprocdef.localst:=st;
{ and insert the procsym in symtable }
st.insert(aktprocsym);
{ set some informations about the main program }
with procinfo do
begin
_class:=nil;
para_offset:=target_info.first_parm_offset;
framepointer:=FRAME_POINTER_REG;
flags:=0;
procdef:=aktprocdef;
end;
end;
procedure proc_unit;
function is_assembler_generated:boolean;
begin
is_assembler_generated:=(Errorcount=0) and
not(
codeSegment.empty and
dataSegment.empty and
bssSegment.empty and
((importssection=nil) or importsSection.empty) and
((resourcesection=nil) or resourceSection.empty) and
((resourcestringlist=nil) or resourcestringList.empty)
);
end;
var
main_file: tinputfile;
st : tsymtable;
unitst : tglobalsymtable;
{$ifdef GDB}
pu : tused_unit;
{$endif GDB}
store_crc,store_interface_crc : cardinal;
s2 : ^string; {Saves stack space}
force_init_final : boolean;
begin
consume(_UNIT);
if compile_level=1 then
Status.IsExe:=false;
if token=_ID then
begin
{ create filenames and unit name }
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);
stringdispose(current_module.modulename);
stringdispose(current_module.realmodulename);
current_module.modulename:=stringdup(pattern);
current_module.realmodulename:=stringdup(orgpattern);
{ check for system unit }
new(s2);
s2^:=upper(SplitName(main_file.name^));
if (cs_check_unit_name in aktglobalswitches) and
not((current_module.modulename^=s2^) or
((length(current_module.modulename^)>8) and
(copy(current_module.modulename^,1,8)=s2^))) then
Message1(unit_e_illegal_unit_name,current_module.realmodulename^);
if (current_module.modulename^='SYSTEM') then
include(aktmoduleswitches,cs_compilesystem);
dispose(s2);
end;
consume(_ID);
consume(_SEMICOLON);
consume(_INTERFACE);
{ global switches are read, so further changes aren't allowed }
current_module.in_global:=false;
{ handle the global switches }
setupglobalswitches;
Message1(unit_u_start_parse_interface,current_module.realmodulename^);
{ update status }
status.currentmodule:=current_module.realmodulename^;
{ maybe turn off m_objpas if we are compiling objpas }
if (current_module.modulename^='OBJPAS') then
exclude(aktmodeswitches,m_objpas);
parse_only:=true;
{ generate now the global symboltable }
st:=tglobalsymtable.create(current_module.modulename^);
refsymtable:=st;
unitst:=tglobalsymtable(st);
{ define first as local to overcome dependency conflicts }
current_module.localsymtable:=st;
{ the unit name must be usable as a unit specifier }
{ inside the unit itself (PM) }
{ this also forbids to have another symbol }
{ with the same name as the unit }
refsymtable.insert(tunitsym.create(current_module.realmodulename^,unitst));
{ load default units, like the system unit }
loaddefaultunits;
{ reset }
make_ref:=true;
lexlevel:=0;
{ insert qualifier for the system unit (allows system.writeln) }
if not(cs_compilesystem in aktmoduleswitches) then
begin
if token=_USES then
begin
loadunits;
{ has it been compiled at a higher level ?}
if current_module.compiled then
begin
{ this unit symtable is obsolete }
{ dispose(unitst,done);
disposed as localsymtable !! }
RestoreUnitSyms;
exit;
end;
end;
{ ... but insert the symbol table later }
st.next:=symtablestack;
symtablestack:=st;
end
else
{ while compiling a system unit, some types are directly inserted }
begin
st.next:=symtablestack;
symtablestack:=st;
insert_intern_types(st);
end;
{ now we know the place to insert the constants }
constsymtable:=symtablestack;
{ move the global symtab from the temporary local to global }
current_module.globalsymtable:=current_module.localsymtable;
current_module.localsymtable:=nil;
reset_global_defs;
{ number all units, so we know if a unit is used by this unit or
needs to be added implicitly }
current_module.numberunits;
{ ... parse the declarations }
Message1(parser_u_parsing_interface,current_module.realmodulename^);
read_interface_declarations;
{ 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;
{else in inteface its somatimes necessary even if unused
st^.allunitsused; }
{$ifdef New_GDB}
write_gdb_info;
{$endIf Def New_GDB}
if not(cs_compilesystem in aktmoduleswitches) then
if (Errorcount=0) then
tppumodule(current_module).getppucrc;
{ Parse the implementation section }
consume(_IMPLEMENTATION);
current_module.in_implementation:=true;
Message1(unit_u_start_parse_implementation,current_module.modulename^);
parse_only:=false;
{ generates static symbol table }
st:=tstaticsymtable.create(current_module.modulename^);
current_module.localsymtable:=st;
{ remove the globalsymtable from the symtable stack }
{ to reinsert it after loading the implementation units }
symtablestack:=unitst.next;
{ we don't want implementation units symbols in unitsymtable !! PM }
refsymtable:=st;
{ Read the implementation units }
parse_implementation_uses(unitst);
if current_module.compiled then
begin
RestoreUnitSyms;
exit;
end;
{ reset ranges/stabs in exported definitions }
reset_global_defs;
{ All units are read, now give them a number }
current_module.numberunits;
{ now we can change refsymtable }
refsymtable:=st;
{ but reinsert the global symtable as lasts }
unitst.next:=symtablestack;
symtablestack:=unitst;
tstoredsymtable(symtablestack).chainoperators;
{$ifdef DEBUG}
test_symtablestack;
{$endif DEBUG}
constsymtable:=symtablestack;
{$ifdef Splitheap}
if testsplit then
begin
Split_Heap;
allow_special:=true;
Switch_to_temp_heap;
end;
{ it will report all crossings }
allow_special:=false;
{$endif Splitheap}
Message1(parser_u_parsing_implementation,current_module.realmodulename^);
{ Compile the unit }
codegen_newprocedure;
gen_main_procsym(current_module.modulename^+'_init',potype_unitinit,st);
aktprocdef.aliasnames.insert('INIT$$'+current_module.modulename^);
aktprocdef.aliasnames.insert(target_info.cprefix+current_module.modulename^+'_init');
compile_proc_body(true,false);
codegen_doneprocedure;
{ avoid self recursive destructor call !! PM }
aktprocdef.localst:=nil;
{ 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 ? }
if force_init_final and ((current_module.flags and uf_init)=0) then
begin
current_module.flags:=current_module.flags or uf_init;
{ now we can insert a cut }
if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create);
genimplicitunitinit(codesegment);
end;
{ finalize? }
if token=_FINALIZATION then
begin
{ set module options }
current_module.flags:=current_module.flags or uf_finalize;
{ Compile the finalize }
codegen_newprocedure;
gen_main_procsym(current_module.modulename^+'_finalize',potype_unitfinalize,st);
aktprocdef.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
aktprocdef.aliasnames.insert(target_info.cprefix+current_module.modulename^+'_finalize');
compile_proc_body(true,false);
codegen_doneprocedure;
end
else if force_init_final then
begin
current_module.flags:=current_module.flags or uf_finalize;
{ now we can insert a cut }
if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create);
genimplicitunitfinal(codesegment);
end;
{ the last char should always be a point }
consume(_POINT);
{ generate a list of threadvars }
InsertThreadvars;
{ Generate resoucestrings }
If ResourceStrings.ResStrCount>0 then
begin
ResourceStrings.CreateResourceStringList;
current_module.flags:=current_module.flags or uf_has_resources;
{ only write if no errors found }
if (Errorcount=0) then
ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
end;
{ avoid self recursive destructor call !! PM }
aktprocdef.localst:=nil;
{ absence does not matter here !! }
aktprocdef.forwarddef:=false;
{ test static symtable }
if (Errorcount=0) then
begin
tstoredsymtable(st).allsymbolsused;
tstoredsymtable(st).allunitsused;
tstoredsymtable(st).allprivatesused;
end;
{ size of the static data }
datasize:=st.datasize;
{$ifdef GDB}
{ add all used definitions even for implementation}
if (cs_debuginfo in aktmoduleswitches) then
begin
{$IfnDef New_GDB}
if assigned(current_module.globalsymtable) then
begin
{ all types }
tglobalsymtable(current_module.globalsymtable).concattypestabto(debuglist);
{ and all local symbols}
tglobalsymtable(current_module.globalsymtable).concatstabto(debuglist);
end;
{ all local types }
tglobalsymtable(st)^.concattypestabto(debuglist);
{ and all local symbols}
st^.concatstabto(debuglist);
{$else New_GDB}
write_gdb_info;
{$endIf Def New_GDB}
end;
{$endif GDB}
reset_global_defs;
if (Errorcount=0) then
begin
{ tests, if all (interface) forwards are resolved }
tstoredsymtable(symtablestack).check_forwards;
{ check if all private fields are used }
tstoredsymtable(symtablestack).allprivatesused;
{ remove cross unit overloads }
tstoredsymtable(symtablestack).unchain_overloaded;
end;
current_module.in_implementation:=false;
{$ifdef GDB}
tglobalsymtable(symtablestack).is_stab_written:=false;
{$endif GDB}
{ 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;
{ generate imports }
if current_module.uses_imports then
importlib.generatelib;
{ insert own objectfile, or say that it's in a library
(no check for an .o when loading) }
if is_assembler_generated then
insertobjectfile
else
current_module.flags:=current_module.flags or uf_no_link;
if cs_local_browser in aktmoduleswitches then
current_module.localsymtable:=refsymtable;
{$ifdef GDB}
pu:=tused_unit(usedunits.first);
while assigned(pu) do
begin
if assigned(pu.u.globalsymtable) then
tglobalsymtable(pu.u.globalsymtable).is_stab_written:=false;
pu:=tused_unit(pu.next);
end;
{$endif GDB}
if is_assembler_generated then
begin
{ finish asmlist by adding segment starts }
insertsegment;
{ assemble }
create_objectfile;
end;
{ Write out the ppufile after the object file has been created }
store_interface_crc:=current_module.interface_crc;
store_crc:=current_module.crc;
if (Errorcount=0) then
tppumodule(current_module).writeppu;
if not(cs_compilesystem in aktmoduleswitches) then
if store_interface_crc<>current_module.interface_crc then
Comment(V_Warning,current_module.ppufilename^+' Interface CRC changed '+
hexstr(store_crc,8)+'<>'+hexstr(current_module.interface_crc,8));
{$ifdef EXTDEBUG}
if not(cs_compilesystem in aktmoduleswitches) then
if (store_crc<>current_module.crc) and simplify_ppu then
Comment(V_Note,current_module.ppufilename^+' implementation CRC changed '+
hexstr(store_crc,8)+'<>'+hexstr(current_module.crc,8));
{$endif EXTDEBUG}
{ remove static symtable (=refsymtable) here to save some mem }
if not (cs_local_browser in aktmoduleswitches) then
begin
st.free;
current_module.localsymtable:=nil;
end;
RestoreUnitSyms;
{ 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;
end;
procedure proc_program(islibrary : boolean);
var
main_file: tinputfile;
st : tsymtable;
hp : tmodule;
begin
DLLsource:=islibrary;
Status.IsLibrary:=IsLibrary;
Status.IsExe:=true;
parse_only:=false;
{ relocation works only without stabs under win32 !! PM }
{ internal assembler uses rva for stabs info
so it should work with relocated DLLs }
if RelocSection and
(target_info.system in [system_i386_win32,system_i386_wdosx]) and
(target_info.assem<>as_i386_pecoff) then
begin
include(aktglobalswitches,cs_link_strip);
{ Warning stabs info does not work with reloc section !! }
if cs_debuginfo in aktmoduleswitches then
begin
Message1(parser_w_parser_reloc_no_debug,current_module.mainsource^);
Message(parser_w_parser_win32_debug_needs_WN);
exclude(aktmoduleswitches,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);
stringdispose(current_module.modulename);
current_module.modulename:=stringdup(pattern);
current_module.islibrary:=true;
exportlib.preparelib(pattern);
consume(_ID);
consume(_SEMICOLON);
end
else
{ is there an program head ? }
if token=_PROGRAM then
begin
consume(_PROGRAM);
stringdispose(current_module.modulename);
stringdispose(current_module.realmodulename);
current_module.modulename:=stringdup(pattern);
current_module.realmodulename:=stringdup(orgpattern);
if (target_info.system in [system_i386_WIN32,system_i386_wdosx]) then
exportlib.preparelib(pattern);
consume(_ID);
if token=_LKLAMMER then
begin
consume(_LKLAMMER);
repeat
consume(_ID);
until not try_to_consume(_COMMA);
consume(_RKLAMMER);
end;
consume(_SEMICOLON);
end
else if (target_info.system in [system_i386_WIN32,system_i386_wdosx]) then
exportlib.preparelib(current_module.modulename^);
{ global switches are read, so further changes aren't allowed }
current_module.in_global:=false;
{ setup things using the global switches }
setupglobalswitches;
{ set implementation flag }
current_module.in_implementation:=true;
{ insert after the unit symbol tables the static symbol table }
{ of the program }
st:=tstaticsymtable.create(current_module.modulename^);;
current_module.localsymtable:=st;
refsymtable:=st;
{ load standard units (system,objpas,profile unit) }
loaddefaultunits;
{ reset }
lexlevel:=0;
{Load the units used by the program we compile.}
if token=_USES then
loadunits;
tstoredsymtable(symtablestack).chainoperators;
{ reset ranges/stabs in exported definitions }
reset_global_defs;
{ All units are read, now give them a number }
current_module.numberunits;
{Insert the name of the main program into the symbol table.}
if current_module.realmodulename^<>'' then
st.insert(tunitsym.create(current_module.realmodulename^,st));
{ ...is also constsymtable, this is the symtable where }
{ the elements of enumeration types are inserted }
constsymtable:=st;
Message1(parser_u_parsing_implementation,current_module.mainsource^);
{The program intialization needs an alias, so it can be called
from the bootstrap code.}
codegen_newprocedure;
if islibrary then
begin
gen_main_procsym(current_module.modulename^+'_main',potype_proginit,st);
aktprocdef.aliasnames.insert(target_info.cprefix+current_module.modulename^+'_main');
{ Win32 startup code needs a single name }
if (target_info.system in [system_i386_win32,system_i386_wdosx]) then
aktprocdef.aliasnames.insert('PASCALMAIN');
{ this code is called from C so we need to save some
registers }
include(aktprocdef.procoptions,po_savestdregs);
end
else
begin
gen_main_procsym('main',potype_proginit,st);
aktprocdef.aliasnames.insert('program_init');
aktprocdef.aliasnames.insert('PASCALMAIN');
aktprocdef.aliasnames.insert(target_info.cprefix+'main');
end;
compile_proc_body(true,false);
{ should we force unit initialization? }
if tstaticsymtable(current_module.localsymtable).needs_init_final then
begin
current_module.flags:=current_module.flags or (uf_init or uf_finalize);
{ Add initialize section }
if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create);
genimplicitunitinit(codesegment);
{ Add finalize section }
if (cs_create_smart in aktmoduleswitches) then
codeSegment.concat(Tai_cut.Create);
genimplicitunitfinal(codesegment);
end;
{ 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
assigned(current_module._exports.first) then
codesegment.concat(tai_const_symbol.create(exportlib.edatalabel));
{ avoid self recursive destructor call !! PM }
aktprocdef.localst:=nil;
{ consider these symbols as global ones for browser
but the typecasting of the globalsymtable with tglobalsymtable
can then lead to problems (PFV)
current_module.globalsymtable:=current_module.localsymtable;
current_module.localsymtable:=nil;}
If ResourceStrings.ResStrCount>0 then
begin
ResourceStrings.CreateResourceStringList;
{ only write if no errors found }
if (Errorcount=0) then
ResourceStrings.WriteResourceFile(ForceExtension(current_module.ppufilename^,'.rst'));
end;
codegen_doneprocedure;
{ finalize? }
if token=_FINALIZATION then
begin
{ set module options }
current_module.flags:=current_module.flags or uf_finalize;
{ Compile the finalize }
codegen_newprocedure;
gen_main_procsym(current_module.modulename^+'_finalize',potype_unitfinalize,st);
aktprocdef.aliasnames.insert('FINALIZE$$'+current_module.modulename^);
aktprocdef.aliasnames.insert(target_info.cprefix+current_module.modulename^+'_finalize');
compile_proc_body(true,false);
codegen_doneprocedure;
end;
{ consume the last point }
consume(_POINT);
{$ifdef New_GDB}
write_gdb_info;
{$endIf Def New_GDB}
{ 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;
{ test static symtable }
if (Errorcount=0) then
begin
tstoredsymtable(st).allsymbolsused;
tstoredsymtable(st).allunitsused;
tstoredsymtable(st).allprivatesused;
end;
{ generate a list of threadvars }
InsertThreadvars;
{ generate imports }
if current_module.uses_imports then
importlib.generatelib;
if islibrary or
(target_info.system in [system_i386_WIN32,system_i386_wdosx]) or
(target_info.system=system_i386_NETWARE) then
exportlib.generatelib;
{ insert Tables and Heap }
insertThreadVarTablesTable;
insertResourceTablesTable;
insertinitfinaltable;
insertheap;
insertstacklength;
datasize:=symtablestack.datasize;
{ finish asmlist by adding segment starts }
insertsegment;
{ insert own objectfile }
insertobjectfile;
{ assemble and link }
create_objectfile;
{ 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;
{ create the executable when we are at level 1 }
if (compile_level=1) then
begin
{ insert all .o files from all loaded units }
hp:=tmodule(loaded_units.first);
while assigned(hp) do
begin
linker.AddModuleFiles(hp);
hp:=tmodule(hp.next);
end;
{ write .def file }
if (cs_link_deffile in aktglobalswitches) then
deffile.writefile;
{ finally we can create a executable }
if (not current_module.is_unit) then
begin
if DLLSource then
linker.MakeSharedLibrary
else
linker.MakeExecutable;
end;
end;
end;
end.
{
$Log$
Revision 1.84 2002-11-15 01:58:53 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.83 2002/11/09 15:33:26 carl
* major alignment updates
Revision 1.82 2002/10/16 06:32:52 michael
+ Renamed thread unit to systhrds
Revision 1.81 2002/10/14 19:42:34 peter
* only use init tables for threadvars
Revision 1.80 2002/10/06 19:41:30 peter
* Add finalization of typed consts
* Finalization of globals in the main program
Revision 1.79 2002/09/09 17:34:15 peter
* tdicationary.replace added to replace and item in a dictionary. This
is only allowed for the same name
* varsyms are inserted in symtable before the types are parsed. This
fixes the long standing "var longint : longint" bug
- consume_idlist and idstringlist removed. The loops are inserted
at the callers place and uses the symtable for duplicate id checking
Revision 1.78 2002/09/07 15:25:07 peter
* old logs removed and tabs fixed
Revision 1.77 2002/09/03 16:26:27 daniel
* Make Tprocdef.defs protected
Revision 1.76 2002/09/02 18:46:26 peter
* insert PASCALMAIN in library for Win32 only
Revision 1.75 2002/08/31 15:59:30 florian
+ HEAP* stuff must be generated for Linux/PPC as well
+ direct assembler reader searches now global and static symtables as well
Revision 1.74 2002/08/25 19:25:20 peter
* sym.insert_in_data removed
* symtable.insertvardata/insertconstdata added
* removed insert_in_data call from symtable.insert, it needs to be
called separatly. This allows to deref the address calculation
* procedures now calculate the parast addresses after the procedure
directives are parsed. This fixes the cdecl parast problem
* push_addr_param has an extra argument that specifies if cdecl is used
or not
Revision 1.73 2002/08/18 20:06:25 peter
* inlining is now also allowed in interface
* renamed write/load to ppuwrite/ppuload
* tnode storing in ppu
* nld,ncon,nbas are already updated for storing in ppu
Revision 1.72 2002/08/17 09:23:39 florian
* first part of procinfo rewrite
Revision 1.71 2002/08/11 13:24:12 peter
* saving of asmsymbols in ppu supported
* asmsymbollist global is removed and moved into a new class
tasmlibrarydata that will hold the info of a .a file which
corresponds with a single module. Added librarydata to tmodule
to keep the library info stored for the module. In the future the
objectfiles will also be stored to the tasmlibrarydata class
* all getlabel/newasmsymbol and friends are moved to the new class
Revision 1.70 2002/08/10 14:46:29 carl
+ moved target_cpu_string to cpuinfo
* renamed asmmode enum.
* assembler reader has now less ifdef's
* move from nppcmem.pas -> ncgmem.pas vec. node.
Revision 1.69 2002/07/26 21:15:41 florian
* rewrote the system handling
Revision 1.68 2002/07/04 20:43:01 florian
* first x86-64 patches
Revision 1.67 2002/07/01 18:46:25 peter
* internal linker
* reorganized aasm layer
Revision 1.66 2002/05/16 19:46:43 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.65 2002/05/14 19:34:49 peter
* removed old logs and updated copyright year
Revision 1.64 2002/05/12 16:53:09 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.63 2002/05/06 19:54:50 carl
+ added more patches from Mazen for SPARC port
Revision 1.62 2002/04/20 21:32:24 carl
+ generic FPC_CHECKPOINTER
+ first parameter offset in stack now portable
* rename some constants
+ move some cpu stuff to other units
- remove unused constents
* fix stacksize for some targets
* fix generic size problems which depend now on EXTEND_SIZE constant
Revision 1.61 2002/04/19 15:46:02 peter
* mangledname rewrite, tprocdef.mangledname is now created dynamicly
in most cases and not written to the ppu
* add mangeledname_prefix() routine to generate the prefix of
manglednames depending on the current procedure, object and module
* removed static procprefix since the mangledname is now build only
on demand from tprocdef.mangledname
Revision 1.60 2002/04/14 16:53:10 carl
+ align code section and data section according to alignment rules
Revision 1.59 2002/04/07 17:58:38 carl
+ generic stack checking
Revision 1.58 2002/04/04 19:06:03 peter
* removed unused units
* use tlocation.size in cg.a_*loc*() routines
}
Reference in New Issue View Git Blame Copy Permalink