fpc/compiler/files.pas

1753 lines
53 KiB
ObjectPascal

{
$Id$
Copyright (c) 1996-98 by Florian Klaempfl
This unit implements an extended file management and the first loading
and searching 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 files;
{$ifdef TP}
{$V+}
{$endif}
{$ifdef TP}
{$define SHORTASMPREFIX}
{$endif}
{$ifdef go32v1}
{$define SHORTASMPREFIX}
{$endif}
{$ifdef go32v2}
{$define SHORTASMPREFIX}
{$endif}
{$ifdef OS2}
{ Allthough OS/2 supports long filenames I play it safe and
use 8.3 filenames, because this allows the compiler to run
on a FAT partition. (DM) }
{$define SHORTASMPREFIX}
{$endif}
interface
uses
globtype,
cobjects,globals,ppu;
const
{$ifdef FPC}
maxunits = 1024;
InputFileBufSize=32*1024;
linebufincrease=512;
{$else}
maxunits = 128;
InputFileBufSize=1024;
linebufincrease=64;
{$endif}
type
trecompile_reason = (rr_unknown,rr_noppu,rr_sourcenewer,
rr_build,rr_libolder,rr_objolder,rr_asmolder,rr_crcchanged);
{$ifdef FPC}
tlongintarr = array[0..1000000] of longint;
{$else}
tlongintarr = array[0..16000] of longint;
{$endif}
plongintarr = ^tlongintarr;
pinputfile = ^tinputfile;
tinputfile = object
path,name : pstring; { path and filename }
next : pinputfile; { next file for reading }
f : file; { current file handle }
is_macro,
endoffile, { still bytes left to read }
closed : boolean; { is the file closed }
buf : pchar; { buffer }
bufstart, { buffer start position in the file }
bufsize, { amount of bytes in the buffer }
maxbufsize : longint; { size in memory for the buffer }
saveinputpointer : pchar; { save fields for scanner variables }
savelastlinepos,
saveline_no : longint;
linebuf : plongintarr; { line buffer to retrieve lines }
maxlinebuf : longint;
ref_count : longint; { to handle the browser refs }
ref_index : longint;
ref_next : pinputfile;
constructor init(const fn:string);
destructor done;
procedure setpos(l:longint);
procedure seekbuf(fpos:longint);
procedure readbuf;
function open:boolean;
procedure close;
procedure tempclose;
function tempopen:boolean;
procedure setmacro(p:pchar;len:longint);
procedure setline(line,linepos:longint);
function getlinestr(l:longint):string;
end;
pfilemanager = ^tfilemanager;
tfilemanager = object
files : pinputfile;
last_ref_index : longint;
cacheindex : longint;
cacheinputfile : pinputfile;
constructor init;
destructor done;
procedure register_file(f : pinputfile);
procedure inverse_register_indexes;
function get_file(l:longint) : pinputfile;
function get_file_name(l :longint):string;
function get_file_path(l :longint):string;
end;
plinkcontaineritem=^tlinkcontaineritem;
tlinkcontaineritem=object(tcontaineritem)
data : pstring;
needlink : longint;
constructor init(const s:string;m:longint);
destructor done;virtual;
end;
plinkcontainer=^tlinkcontainer;
tlinkcontainer=object(tcontainer)
constructor Init;
procedure insert(const s : string;m:longint);
function get(var m:longint) : string;
function getusemask(mask:longint) : string;
function find(const s:string):boolean;
end;
{$ifndef NEWMAP}
tunitmap = array[0..maxunits-1] of pointer;
punitmap = ^tunitmap;
pmodule = ^tmodule;
{$else NEWMAP}
pmodule = ^tmodule;
tunitmap = array[0..maxunits-1] of pmodule;
punitmap = ^tunitmap;
{$endif NEWMAP}
tmodule = object(tlinkedlist_item)
ppufile : pppufile; { the PPU file }
crc,
interface_crc,
flags : longint; { the PPU flags }
compiled, { unit is already compiled }
do_reload, { force reloading of the unit }
do_assemble, { only assemble the object, don't recompile }
do_compile, { need to compile the sources }
sources_avail, { if all sources are reachable }
is_unit,
in_compile, { is it being compiled ?? }
in_second_compile, { is this unit being compiled for the 2nd time? }
in_second_load, { is this unit PPU loaded a 2nd time? }
in_implementation, { processing the implementation part? }
in_global : boolean; { allow global settings }
recompile_reason : trecompile_reason; { the reason why the unit should be recompiled }
islibrary : boolean; { if it is a library (win32 dll) }
map : punitmap; { mapping of all used units }
unitcount : word; { local unit counter }
unit_index : word; { global counter for browser }
globalsymtable, { pointer to the local/static symtable of this unit }
localsymtable : pointer; { pointer to the psymtable of this unit }
scanner : pointer; { scanner object used }
loaded_from : pmodule;
uses_imports : boolean; { Set if the module imports from DLL's.}
imports : plinkedlist;
_exports : plinkedlist;
sourcefiles : pfilemanager;
resourcefiles : tstringcontainer;
linkunitofiles,
linkunitstaticlibs,
linkunitsharedlibs,
linkotherofiles, { objects,libs loaded from the source }
linkothersharedlibs, { using $L or $LINKLIB or import lib (for linux) }
linkotherstaticlibs : tlinkcontainer;
used_units : tlinkedlist;
dependent_units : tlinkedlist;
localunitsearchpath, { local searchpaths }
localobjectsearchpath,
localincludesearchpath,
locallibrarysearchpath : pstring;
path, { path where the module is find/created }
outpath,
modulename, { name of the module in uppercase }
objfilename, { fullname of the objectfile }
asmfilename, { fullname of the assemblerfile }
ppufilename, { fullname of the ppufile }
staticlibfilename, { fullname of the static libraryfile }
sharedlibfilename, { fullname of the shared libraryfile }
exefilename, { fullname of the exefile }
asmprefix, { prefix for the smartlink asmfiles }
mainsource : pstring; { name of the main sourcefile }
{$ifdef Test_Double_checksum}
crc_array : pointer;
crc_size : longint;
crc_array2 : pointer;
crc_size2 : longint;
{$endif def Test_Double_checksum}
constructor init(const s:string;_is_unit:boolean);
destructor done;virtual;
procedure reset;
procedure setfilename(const fn:string;allowoutput:boolean);
function openppu:boolean;
function search_unit(const n : string;onlysource:boolean):boolean;
end;
pused_unit = ^tused_unit;
tused_unit = object(tlinkedlist_item)
unitid : word;
name : pstring;
checksum,
interface_checksum : longint;
loaded : boolean;
in_uses,
in_interface,
is_stab_written : boolean;
u : pmodule;
constructor init(_u : pmodule;intface:boolean);
constructor init_to_load(const n:string;c,intfc:longint;intface:boolean);
destructor done;virtual;
end;
pdependent_unit = ^tdependent_unit;
tdependent_unit = object(tlinkedlist_item)
u : pmodule;
constructor init(_u : pmodule);
end;
var
main_module : pmodule; { Main module of the program }
current_module : pmodule; { Current module which is compiled }
current_ppu : pppufile; { Current ppufile which is read }
global_unit_count : word;
usedunits : tlinkedlist; { Used units for this program }
loaded_units : tlinkedlist; { All loaded units }
function get_source_file(moduleindex,fileindex : word) : pinputfile;
implementation
uses
{$ifdef Delphi}
dmisc,
{$else Delphi}
dos,
{$endif Delphi}
verbose,systems,
symtable,scanner;
{****************************************************************************
TINPUTFILE
****************************************************************************}
constructor tinputfile.init(const fn:string);
var
p:dirstr;
n:namestr;
e:extstr;
begin
FSplit(fn,p,n,e);
name:=stringdup(n+e);
path:=stringdup(p);
next:=nil;
{ file info }
is_macro:=false;
endoffile:=false;
closed:=true;
buf:=nil;
bufstart:=0;
bufsize:=0;
maxbufsize:=InputFileBufSize;
{ save fields }
saveinputpointer:=nil;
saveline_no:=0;
savelastlinepos:=0;
{ indexing refs }
ref_next:=nil;
ref_count:=0;
ref_index:=0;
{ line buffer }
linebuf:=nil;
maxlinebuf:=0;
end;
destructor tinputfile.done;
begin
if not closed then
close;
stringdispose(path);
stringdispose(name);
{ free memory }
if assigned(linebuf) then
freemem(linebuf,maxlinebuf shl 2);
end;
procedure tinputfile.setpos(l:longint);
begin
bufstart:=l;
end;
procedure tinputfile.seekbuf(fpos:longint);
begin
if closed then
exit;
seek(f,fpos);
bufstart:=fpos;
bufsize:=0;
end;
procedure tinputfile.readbuf;
{$ifdef TP}
var
w : word;
{$endif}
begin
if is_macro then
endoffile:=true;
if closed then
exit;
inc(bufstart,bufsize);
{$ifdef VER70}
blockread(f,buf^,maxbufsize-1,w);
bufsize:=w;
{$else}
blockread(f,buf^,maxbufsize-1,bufsize);
{$endif}
buf[bufsize]:=#0;
endoffile:=eof(f);
end;
function tinputfile.open:boolean;
var
ofm : byte;
begin
open:=false;
if not closed then
Close;
ofm:=filemode;
filemode:=0;
Assign(f,path^+name^);
{$I-}
reset(f,1);
{$I+}
filemode:=ofm;
if ioresult<>0 then
exit;
{ file }
endoffile:=false;
closed:=false;
Getmem(buf,MaxBufsize);
bufstart:=0;
bufsize:=0;
open:=true;
end;
procedure tinputfile.close;
var
i : word;
begin
if is_macro then
begin
if assigned(buf) then
Freemem(buf,maxbufsize);
buf:=nil;
{is_macro:=false;
still needed for dispose in scanner PM }
closed:=true;
exit;
end;
if not closed then
begin
{$I-}
system.close(f);
{$I+}
i:=ioresult;
closed:=true;
end;
if assigned(buf) then
begin
Freemem(buf,maxbufsize);
buf:=nil;
end;
bufstart:=0;
end;
procedure tinputfile.tempclose;
var
i : word;
begin
if is_macro then
exit;
if not closed then
begin
{$I-}
system.close(f);
{$I+}
i:=ioresult;
Freemem(buf,maxbufsize);
buf:=nil;
closed:=true;
end;
end;
function tinputfile.tempopen:boolean;
var
ofm : byte;
begin
tempopen:=false;
if is_macro then
begin
tempopen:=true;
exit;
end;
if not closed then
exit;
ofm:=filemode;
filemode:=0;
Assign(f,path^+name^);
{$I-}
reset(f,1);
{$I+}
filemode:=ofm;
if ioresult<>0 then
exit;
closed:=false;
{ get new mem }
Getmem(buf,maxbufsize);
{ restore state }
seek(f,BufStart);
bufsize:=0;
readbuf;
tempopen:=true;
end;
procedure tinputfile.setmacro(p:pchar;len:longint);
begin
{ create new buffer }
getmem(buf,len+1);
move(p^,buf^,len);
buf[len]:=#0;
{ reset }
bufstart:=0;
bufsize:=len;
maxbufsize:=len+1;
is_macro:=true;
endoffile:=true;
closed:=true;
end;
procedure tinputfile.setline(line,linepos:longint);
var
oldlinebuf : plongintarr;
begin
if line<1 then
exit;
while (line>=maxlinebuf) do
begin
oldlinebuf:=linebuf;
{ create new linebuf and move old info }
getmem(linebuf,(maxlinebuf+linebufincrease) shl 2);
if assigned(oldlinebuf) then
begin
move(oldlinebuf^,linebuf^,maxlinebuf shl 2);
freemem(oldlinebuf,maxlinebuf shl 2);
end;
fillchar(linebuf^[maxlinebuf],linebufincrease shl 2,0);
inc(maxlinebuf,linebufincrease);
end;
linebuf^[line]:=linepos;
end;
function tinputfile.getlinestr(l:longint):string;
var
c : char;
i,
fpos : longint;
p : pchar;
begin
getlinestr:='';
if l<maxlinebuf then
begin
fpos:=linebuf^[l];
{ fpos is set negativ if the line was already written }
{ but we still know the correct value }
if fpos<0 then
fpos:=-fpos+1;
if closed then
open;
{ in current buf ? }
if (fpos<bufstart) or (fpos>bufstart+bufsize) then
begin
seekbuf(fpos);
readbuf;
end;
{ the begin is in the buf now simply read until #13,#10 }
i:=0;
p:=@buf[fpos-bufstart];
repeat
c:=p^;
if c=#0 then
begin
if endoffile then
break;
readbuf;
p:=buf;
c:=p^;
end;
if c in [#10,#13] then
break;
inc(i);
getlinestr[i]:=c;
inc(longint(p));
until (i=255);
{$ifndef TP}
{$ifopt H+}
setlength(getlinestr,i);
{$else}
getlinestr[0]:=chr(i);
{$endif}
{$else}
getlinestr[0]:=chr(i);
{$endif}
end;
end;
{****************************************************************************
TFILEMANAGER
****************************************************************************}
constructor tfilemanager.init;
begin
files:=nil;
last_ref_index:=0;
cacheindex:=0;
cacheinputfile:=nil;
end;
destructor tfilemanager.done;
var
hp : pinputfile;
begin
hp:=files;
while assigned(hp) do
begin
files:=files^.ref_next;
dispose(hp,done);
hp:=files;
end;
last_ref_index:=0;
end;
procedure tfilemanager.register_file(f : pinputfile);
begin
inc(last_ref_index);
f^.ref_next:=files;
f^.ref_index:=last_ref_index;
files:=f;
{ update cache }
cacheindex:=last_ref_index;
cacheinputfile:=f;
{$ifdef FPC}
{$ifdef heaptrc}
writeln(stderr,f^.name^,' index ',current_module^.unit_index*100000+f^.ref_index);
{$endif heaptrc}
{$endif FPC}
end;
{ this procedure is necessary after loading the
sources files from a PPU file PM }
procedure tfilemanager.inverse_register_indexes;
var
f : pinputfile;
begin
f:=files;
while assigned(f) do
begin
f^.ref_index:=last_ref_index-f^.ref_index+1;
f:=f^.ref_next;
end;
{ reset cache }
cacheindex:=0;
cacheinputfile:=nil;
end;
function tfilemanager.get_file(l :longint) : pinputfile;
var
ff : pinputfile;
begin
{ check cache }
if (l=cacheindex) and assigned(cacheinputfile) then
begin
get_file:=cacheinputfile;
exit;
end;
ff:=files;
while assigned(ff) and (ff^.ref_index<>l) do
ff:=ff^.ref_next;
get_file:=ff;
end;
function tfilemanager.get_file_name(l :longint):string;
var
hp : pinputfile;
begin
hp:=get_file(l);
if assigned(hp) then
get_file_name:=hp^.name^
else
get_file_name:='';
end;
function tfilemanager.get_file_path(l :longint):string;
var
hp : pinputfile;
begin
hp:=get_file(l);
if assigned(hp) then
get_file_path:=hp^.path^
else
get_file_path:='';
end;
function get_source_file(moduleindex,fileindex : word) : pinputfile;
var
hp : pmodule;
f : pinputfile;
begin
hp:=pmodule(loaded_units.first);
while assigned(hp) and (hp^.unit_index<>moduleindex) do
hp:=pmodule(hp^.next);
get_source_file:=nil;
if not assigned(hp) then
exit;
f:=pinputfile(hp^.sourcefiles^.files);
while assigned(f) do
begin
if f^.ref_index=fileindex then
begin
get_source_file:=f;
exit;
end;
f:=pinputfile(f^.ref_next);
end;
end;
{****************************************************************************
TLinkContainerItem
****************************************************************************}
constructor TLinkContainerItem.Init(const s:string;m:longint);
begin
inherited Init;
data:=stringdup(s);
needlink:=m;
end;
destructor TLinkContainerItem.Done;
begin
stringdispose(data);
end;
{****************************************************************************
TLinkContainer
****************************************************************************}
constructor TLinkContainer.Init;
begin
inherited init;
end;
procedure TLinkContainer.insert(const s : string;m:longint);
var
newnode : plinkcontaineritem;
begin
if find(s) then
exit;
new(newnode,init(s,m));
inherited insert(newnode);
end;
function TLinkContainer.get(var m:longint) : string;
var
p : plinkcontaineritem;
begin
p:=plinkcontaineritem(inherited get);
if p=nil then
begin
get:='';
m:=0;
exit;
end;
get:=p^.data^;
m:=p^.needlink;
dispose(p,done);
end;
function TLinkContainer.getusemask(mask:longint) : string;
var
p : plinkcontaineritem;
found : boolean;
begin
found:=false;
repeat
p:=plinkcontaineritem(inherited get);
if p=nil then
begin
getusemask:='';
exit;
end;
getusemask:=p^.data^;
found:=(p^.needlink and mask)<>0;
dispose(p,done);
until found;
end;
function TLinkContainer.find(const s:string):boolean;
var
newnode : plinkcontaineritem;
begin
find:=false;
newnode:=plinkcontaineritem(root);
while assigned(newnode) do
begin
if newnode^.data^=s then
begin
find:=true;
exit;
end;
newnode:=plinkcontaineritem(newnode^.next);
end;
end;
{****************************************************************************
TMODULE
****************************************************************************}
procedure tmodule.setfilename(const fn:string;allowoutput:boolean);
var
p : dirstr;
n : NameStr;
e : ExtStr;
begin
stringdispose(objfilename);
stringdispose(asmfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(exefilename);
stringdispose(outpath);
stringdispose(path);
{ Create names }
fsplit(fn,p,n,e);
n:=FixFileName(n);
{ set path }
path:=stringdup(FixPath(p,false));
{ obj,asm,ppu names }
p:=path^;
if AllowOutput then
begin
if (OutputUnitDir<>'') then
p:=OutputUnitDir
else
if (OutputExeDir<>'') then
p:=OutputExeDir;
end;
outpath:=stringdup(p);
objfilename:=stringdup(p+n+target_info.objext);
asmfilename:=stringdup(p+n+target_info.asmext);
ppufilename:=stringdup(p+n+target_info.unitext);
{ lib and exe could be loaded with a file specified with -o }
if AllowOutput and (OutputFile<>'') then
n:=OutputFile;
staticlibfilename:=stringdup(p+target_os.libprefix+n+target_os.staticlibext);
if target_info.target=target_i386_WIN32 then
sharedlibfilename:=stringdup(p+n+target_os.sharedlibext)
else
sharedlibfilename:=stringdup(p+target_os.libprefix+n+target_os.sharedlibext);
{ output dir of exe can be specified separatly }
if AllowOutput and (OutputExeDir<>'') then
p:=OutputExeDir
else
p:=path^;
exefilename:=stringdup(p+n+target_info.exeext);
end;
function tmodule.openppu:boolean;
var
objfiletime,
ppufiletime,
asmfiletime : longint;
begin
openppu:=false;
Message1(unit_t_ppu_loading,ppufilename^);
{ Get ppufile time (also check if the file exists) }
ppufiletime:=getnamedfiletime(ppufilename^);
if ppufiletime=-1 then
exit;
{ Open the ppufile }
Message1(unit_u_ppu_name,ppufilename^);
ppufile:=new(pppufile,init(ppufilename^));
ppufile^.change_endian:=source_os.endian<>target_os.endian;
if not ppufile^.open then
begin
dispose(ppufile,done);
Message(unit_u_ppu_file_too_short);
exit;
end;
{ check for a valid PPU file }
if not ppufile^.CheckPPUId then
begin
dispose(ppufile,done);
Message(unit_u_ppu_invalid_header);
exit;
end;
{ check for allowed PPU versions }
if not (ppufile^.GetPPUVersion = CurrentPPUVersion) then
begin
dispose(ppufile,done);
Message1(unit_u_ppu_invalid_version,tostr(ppufile^.GetPPUVersion));
exit;
end;
{ check the target processor }
if ttargetcpu(ppufile^.header.cpu)<>target_cpu then
begin
dispose(ppufile,done);
Message(unit_u_ppu_invalid_processor);
exit;
end;
{ check target }
if ttarget(ppufile^.header.target)<>target_info.target then
begin
dispose(ppufile,done);
Message(unit_u_ppu_invalid_target);
exit;
end;
{ Load values to be access easier }
flags:=ppufile^.header.flags;
crc:=ppufile^.header.checksum;
interface_crc:=ppufile^.header.interface_checksum;
{ Show Debug info }
Message1(unit_u_ppu_time,filetimestring(ppufiletime));
Message1(unit_u_ppu_flags,tostr(flags));
Message1(unit_u_ppu_crc,tostr(ppufile^.header.checksum));
Message1(unit_u_ppu_crc,tostr(ppufile^.header.interface_checksum)+' (intfc)');
{ check the object and assembler file to see if we need only to
assemble, only if it's not in a library }
do_compile:=false;
if (flags and uf_in_library)=0 then
begin
if (flags and uf_smart_linked)<>0 then
begin
objfiletime:=getnamedfiletime(staticlibfilename^);
Message2(unit_u_check_time,staticlibfilename^,filetimestring(objfiletime));
if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
begin
recompile_reason:=rr_libolder;
Message(unit_u_recompile_staticlib_is_older);
do_compile:=true;
exit;
end;
end;
if (flags and uf_static_linked)<>0 then
begin
{ the objectfile should be newer than the ppu file }
objfiletime:=getnamedfiletime(objfilename^);
Message2(unit_u_check_time,objfilename^,filetimestring(objfiletime));
if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
begin
{ check if assembler file is older than ppu file }
asmfileTime:=GetNamedFileTime(asmfilename^);
Message2(unit_u_check_time,asmfilename^,filetimestring(asmfiletime));
if (asmfiletime<0) or (ppufiletime>asmfiletime) then
begin
Message(unit_u_recompile_obj_and_asm_older);
recompile_reason:=rr_objolder;
do_compile:=true;
exit;
end
else
begin
Message(unit_u_recompile_obj_older_than_asm);
if not(cs_asm_extern in aktglobalswitches) then
begin
do_compile:=true;
recompile_reason:=rr_asmolder;
exit;
end;
end;
end;
end;
end;
openppu:=true;
end;
function tmodule.search_unit(const n : string;onlysource:boolean):boolean;
var
singlepathstring,
filename : string;
Function UnitExists(const ext:string):boolean;
begin
Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
UnitExists:=FileExists(Singlepathstring+FileName+ext);
end;
Function SearchPath(unitpath:string):boolean;
var
found : boolean;
start,i : longint;
ext : string[8];
begin
start:=1;
Found:=false;
repeat
{ Create current path to check }
i:=pos(';',unitpath);
if i=0 then
i:=length(unitpath)+1;
singlepathstring:=FixPath(copy(unitpath,start,i-start),false);
delete(unitpath,start,i-start+1);
if not onlysource then
begin
{ Check for PPL file }
if not Found then
begin
Found:=UnitExists(target_info.unitlibext);
if Found then
Begin
SetFileName(SinglePathString+FileName,false);
Found:=OpenPPU;
End;
end;
{ Check for PPU file }
if not Found then
begin
Found:=UnitExists(target_info.unitext);
if Found then
Begin
SetFileName(SinglePathString+FileName,false);
Found:=OpenPPU;
End;
end;
end;
{ Check for Sources }
if not Found then
begin
ppufile:=nil;
do_compile:=true;
recompile_reason:=rr_noppu;
{Check for .pp file}
Found:=UnitExists(target_os.sourceext);
if Found then
Ext:=target_os.sourceext
else
begin
{Check for .pas}
Found:=UnitExists(target_os.pasext);
if Found then
Ext:=target_os.pasext;
end;
stringdispose(mainsource);
if Found then
begin
sources_avail:=true;
{Load Filenames when found}
mainsource:=StringDup(SinglePathString+FileName+Ext);
SetFileName(SinglePathString+FileName,false);
end
else
sources_avail:=false;
end;
until Found or (unitpath='');
SearchPath:=Found;
end;
var
fnd : boolean;
begin
filename:=FixFileName(n);
{ try to find unit
1. cwd
2. local unit path
3. global unit path }
fnd:=SearchPath('.');
if (not fnd) and assigned(current_module^.LocalUnitSearchPath) then
fnd:=SearchPath(current_module^.LocalUnitSearchPath^);
if (not fnd) then
fnd:=SearchPath(UnitSearchPath);
{ try to find a file with the first 8 chars of the modulename, like
dos }
if (not fnd) and (length(filename)>8) then
begin
filename:=copy(filename,1,8);
fnd:=SearchPath('.');
if (not fnd) and assigned(current_module^.LocalUnitSearchPath) then
fnd:=SearchPath(current_module^.LocalUnitSearchPath^);
if not fnd then
fnd:=SearchPath(UnitSearchPath);
end;
search_unit:=fnd;
end;
procedure tmodule.reset;
var
pm : pdependent_unit;
begin
if assigned(scanner) then
pscannerfile(scanner)^.invalid:=true;
if assigned(globalsymtable) then
begin
dispose(punitsymtable(globalsymtable),done);
globalsymtable:=nil;
end;
if assigned(localsymtable) then
begin
dispose(punitsymtable(localsymtable),done);
localsymtable:=nil;
end;
if assigned(map) then
begin
dispose(map);
map:=nil;
end;
if assigned(ppufile) then
begin
dispose(ppufile,done);
ppufile:=nil;
end;
sourcefiles^.done;
sourcefiles^.init;
imports^.done;
imports^.init;
_exports^.done;
_exports^.init;
used_units.done;
used_units.init;
{ all units that depend on this one must be recompiled ! }
pm:=pdependent_unit(dependent_units.first);
while assigned(pm) do
begin
if pm^.u^.in_second_compile then
Comment(v_debug,'No reload already in second compile: '+pm^.u^.modulename^)
else
begin
pm^.u^.do_reload:=true;
Comment(v_debug,'Reloading '+pm^.u^.modulename^+' needed because '+modulename^+' is reloaded');
end;
pm:=pdependent_unit(pm^.next);
end;
dependent_units.done;
dependent_units.init;
resourcefiles.done;
resourcefiles.init;
linkunitofiles.done;
linkunitofiles.init;
linkunitstaticlibs.done;
linkunitstaticlibs.init;
linkunitsharedlibs.done;
linkunitsharedlibs.init;
linkotherofiles.done;
linkotherofiles.init;
linkotherstaticlibs.done;
linkotherstaticlibs.init;
linkothersharedlibs.done;
linkothersharedlibs.init;
uses_imports:=false;
do_assemble:=false;
do_compile:=false;
{ sources_avail:=true;
should not be changed PM }
compiled:=false;
in_implementation:=false;
in_global:=true;
loaded_from:=nil;
flags:=0;
crc:=0;
interface_crc:=0;
unitcount:=1;
recompile_reason:=rr_unknown;
end;
constructor tmodule.init(const s:string;_is_unit:boolean);
var
p : dirstr;
n : namestr;
e : extstr;
begin
FSplit(s,p,n,e);
{ Programs have the name program to don't conflict with dup id's }
if _is_unit then
modulename:=stringdup(Upper(n))
else
modulename:=stringdup('PROGRAM');
mainsource:=stringdup(s);
ppufilename:=nil;
objfilename:=nil;
asmfilename:=nil;
staticlibfilename:=nil;
sharedlibfilename:=nil;
exefilename:=nil;
outpath:=nil;
{ Dos has the famous 8.3 limit :( }
{$ifdef SHORTASMPREFIX}
asmprefix:=stringdup(FixFileName('as'));
{$else}
asmprefix:=stringdup(FixFileName(n));
{$endif}
path:=nil;
setfilename(p+n,true);
localunitsearchpath:=nil;
localobjectsearchpath:=nil;
localincludesearchpath:=nil;
locallibrarysearchpath:=nil;
used_units.init;
dependent_units.init;
new(sourcefiles,init);
resourcefiles.init;
linkunitofiles.init;
linkunitstaticlibs.init;
linkunitsharedlibs.init;
linkotherofiles.init;
linkotherstaticlibs.init;
linkothersharedlibs.init;
ppufile:=nil;
scanner:=nil;
map:=nil;
globalsymtable:=nil;
localsymtable:=nil;
loaded_from:=nil;
flags:=0;
crc:=0;
interface_crc:=0;
do_reload:=false;
unitcount:=1;
inc(global_unit_count);
unit_index:=global_unit_count;
do_assemble:=false;
do_compile:=false;
sources_avail:=true;
compiled:=false;
recompile_reason:=rr_unknown;
in_second_load:=false;
in_compile:=false;
in_second_compile:=false;
in_implementation:=false;
in_global:=true;
is_unit:=_is_unit;
islibrary:=false;
uses_imports:=false;
imports:=new(plinkedlist,init);
_exports:=new(plinkedlist,init);
{ search the PPU file if it is an unit }
if is_unit then
search_unit(modulename^,false);
end;
destructor tmodule.done;
{$ifdef MEMDEBUG}
var
d : tmemdebug;
{$endif}
begin
if assigned(map) then
dispose(map);
if assigned(ppufile) then
dispose(ppufile,done);
ppufile:=nil;
if assigned(imports) then
dispose(imports,done);
imports:=nil;
if assigned(_exports) then
dispose(_exports,done);
_exports:=nil;
if assigned(scanner) then
pscannerfile(scanner)^.invalid:=true;
if assigned(sourcefiles) then
dispose(sourcefiles,done);
sourcefiles:=nil;
used_units.done;
dependent_units.done;
resourcefiles.done;
linkunitofiles.done;
linkunitstaticlibs.done;
linkunitsharedlibs.done;
linkotherofiles.done;
linkotherstaticlibs.done;
linkothersharedlibs.done;
stringdispose(objfilename);
stringdispose(asmfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(exefilename);
stringdispose(outpath);
stringdispose(path);
stringdispose(modulename);
stringdispose(mainsource);
stringdispose(asmprefix);
stringdispose(localunitsearchpath);
stringdispose(localobjectsearchpath);
stringdispose(localincludesearchpath);
stringdispose(locallibrarysearchpath);
{$ifdef MEMDEBUG}
d.init('symtable');
{$endif}
if assigned(globalsymtable) then
dispose(punitsymtable(globalsymtable),done);
globalsymtable:=nil;
if assigned(localsymtable) then
dispose(punitsymtable(localsymtable),done);
localsymtable:=nil;
{$ifdef MEMDEBUG}
d.done;
{$endif}
inherited done;
end;
{****************************************************************************
TUSED_UNIT
****************************************************************************}
constructor tused_unit.init(_u : pmodule;intface:boolean);
begin
u:=_u;
in_interface:=intface;
in_uses:=false;
is_stab_written:=false;
loaded:=true;
name:=stringdup(_u^.modulename^);
checksum:=_u^.crc;
interface_checksum:=_u^.interface_crc;
unitid:=0;
end;
constructor tused_unit.init_to_load(const n:string;c,intfc:longint;intface:boolean);
begin
u:=nil;
in_interface:=intface;
in_uses:=false;
is_stab_written:=false;
loaded:=false;
name:=stringdup(n);
checksum:=c;
interface_checksum:=intfc;
unitid:=0;
end;
destructor tused_unit.done;
begin
stringdispose(name);
inherited done;
end;
{****************************************************************************
TDENPENDENT_UNIT
****************************************************************************}
constructor tdependent_unit.init(_u : pmodule);
begin
u:=_u;
end;
end.
{
$Log$
Revision 1.102 1999-08-31 15:51:10 pierre
* in_second_compile cleaned up, in_compile and in_second_load added
Revision 1.101 1999/08/27 10:43:20 pierre
+ interface CRC check with ifdef Test_double_checksum added
Revision 1.100 1999/08/24 13:14:01 peter
* MEMDEBUG to see the sizes of asmlist,asmsymbols,symtables
Revision 1.99 1999/07/18 14:47:26 florian
* bug 487 fixed, (inc(<property>) isn't allowed)
* more fixes to compile with Delphi
Revision 1.98 1999/07/18 10:19:51 florian
* made it compilable with Dlephi 4 again
+ fixed problem with large stack allocations on win32
Revision 1.97 1999/07/14 21:19:03 florian
+ implemented a better error message if a PPU file isn't found as suggested
by Lee John
Revision 1.96 1999/07/03 00:29:47 peter
* new link writing to the ppu, one .ppu is needed for all link types,
static (.o) is now always created also when smartlinking is used
Revision 1.95 1999/05/13 21:59:25 peter
* removed oldppu code
* warning if objpas is loaded from uses
* first things for new deref writing
Revision 1.94 1999/05/04 21:44:42 florian
* changes to compile it with Delphi 4.0
Revision 1.93 1999/04/26 13:31:29 peter
* release storenumber,double_checksum
Revision 1.92 1999/04/25 15:08:36 peter
* small fixes for double_checksum
Revision 1.91 1999/04/21 09:43:36 peter
* storenumber works
* fixed some typos in double_checksum
+ incompatible types type1 and type2 message (with storenumber)
Revision 1.90 1999/04/14 09:14:48 peter
* first things to store the symbol/def number in the ppu
Revision 1.89 1999/04/07 15:39:29 pierre
+ double_checksum code added
Revision 1.88 1999/03/25 16:55:29 peter
+ unitpath,librarypath,includepath,objectpath directives
Revision 1.87 1999/02/16 00:48:23 peter
* save in the ppu if linked with obj file instead of using the
library flag, so the .inc files are also checked
Revision 1.86 1999/02/05 08:54:24 pierre
+ linkofiles splitted inot linkofiles and linkunitfiles
because linkofiles must be stored with directory
to enabled linking of different objects with same name
in a different directory
Revision 1.85 1999/01/14 21:47:11 peter
* status.currentmodule is now also updated
+ status.currentsourcepath
Revision 1.84 1999/01/14 11:38:39 daniel
* Exe name derived from target_info instead of target_os
Revision 1.83 1999/01/13 15:02:00 daniel
* Tinputfile.readbuf eof bugfix
Revision 1.82 1999/01/12 14:25:26 peter
+ BrowserLog for browser.log generation
+ BrowserCol for browser info in TCollections
* released all other UseBrowser
Revision 1.81 1998/12/28 23:26:14 peter
+ resource file handling ($R directive) for Win32
Revision 1.80 1998/12/16 00:27:19 peter
* removed some obsolete version checks
Revision 1.79 1998/12/11 00:03:14 peter
+ globtype,tokens,version unit splitted from globals
Revision 1.78 1998/12/04 10:18:07 florian
* some stuff for procedures of object added
* bug with overridden virtual constructors fixed (reported by Italo Gomes)
Revision 1.77 1998/12/02 16:23:37 jonas
* changed "if longintvar in set" to case or "if () or () .." statements
* tree.pas: changed inlinenumber (and associated constructor/vars) to a byte
Revision 1.76 1998/12/01 12:51:19 peter
* fixed placing of ppas.sh and link.res when using -FE
Revision 1.75 1998/11/16 15:41:40 peter
* tp7 didn't like my ifopt H+ :(
Revision 1.74 1998/11/16 12:18:01 peter
* H+ fixes
Revision 1.73 1998/11/16 11:28:58 pierre
* stackcheck removed for i386_win32
* exportlist does not crash at least !!
(was need for tests dir !)z
Revision 1.72 1998/11/15 16:32:35 florian
* some stuff of Pavel implement (win32 dll creation)
* bug with ansistring function results fixed
Revision 1.71 1998/11/06 09:45:40 pierre
* bug on errors (file used after dispose !) fixed
Revision 1.70 1998/11/03 11:33:14 peter
+ search_unit arg to only search for sources
Revision 1.69 1998/10/29 11:35:44 florian
* some dll support for win32
* fixed assembler writing for PalmOS
Revision 1.68 1998/10/27 10:22:34 florian
+ First things for win32 export sections
Revision 1.67 1998/10/26 22:23:29 peter
+ fixpath() has an extra option to allow a ./ as path
Revision 1.66 1998/10/19 18:07:11 peter
+ external dll_name name func support for linux
Revision 1.65 1998/10/15 12:22:25 pierre
* close include files immediately after end reading
instead of waiting until unit compilation ended !
Revision 1.64 1998/10/14 13:38:19 peter
* fixed path with staticlib/objects in ppufiles
Revision 1.63 1998/10/14 11:02:49 daniel
* Stupid typo fixed.
Revision 1.62 1998/10/14 10:59:37 daniel
* Staticlibfilename now doesn't include path.
Revision 1.61 1998/10/14 10:57:25 daniel
* Dirstr, namestr, extstr.
* $V+ to prevent Peter from forgetting this.
* OS/2 compiler uses 8.3 filenames to support running the compiler on an old
DOS FAT partition.
Revision 1.60 1998/10/14 10:45:07 pierre
* ppu problems for m68k fixed (at least in cross compiling)
* one last memory leak for sysamiga fixed
* the amiga RTL compiles now completely !!
Revision 1.59 1998/10/13 14:01:07 peter
* fixed -al
Revision 1.58 1998/10/12 11:59:00 peter
+ show name and date of .o and .s files which the compiler checks
Revision 1.57 1998/10/09 16:36:03 pierre
* some memory leaks specific to usebrowser define fixed
* removed tmodule.implsymtable (was like tmodule.localsymtable)
Revision 1.56 1998/10/09 08:56:26 pierre
* several memory leaks fixed
Revision 1.55 1998/10/08 23:28:54 peter
* -vu shows unit info, -vt shows tried/used files
Revision 1.54 1998/10/08 17:17:19 pierre
* current_module old scanner tagged as invalid if unit is recompiled
+ added ppheap for better info on tracegetmem of heaptrc
(adds line column and file index)
* several memory leaks removed ith help of heaptrc !!
Revision 1.53 1998/10/08 13:48:43 peter
* fixed memory leaks for do nothing source
* fixed unit interdependency
Revision 1.52 1998/10/06 22:09:48 peter
* fixed for compiling with 0.99.8 due circular units
Revision 1.51 1998/10/06 17:16:47 pierre
* some memory leaks fixed (thanks to Peter for heaptrc !)
Revision 1.50 1998/09/30 16:43:34 peter
* fixed unit interdependency with circular uses
Revision 1.49 1998/09/28 16:57:20 pierre
* changed all length(p^.value_str^) into str_length(p)
to get it work with and without ansistrings
* changed sourcefiles field of tmodule to a pointer
Revision 1.48 1998/09/24 23:46:34 peter
+ outputdir support
Revision 1.47 1998/09/22 17:13:43 pierre
+ browsing updated and developed
records and objects fields are also stored
Revision 1.46 1998/09/21 08:45:10 pierre
+ added vmt_offset in tobjectdef.write for fututre use
(first steps to have objects without vmt if no virtual !!)
+ added fpu_used field for tabstractprocdef :
sets this level to 2 if the functions return with value in FPU
(is then set to correct value at parsing of implementation)
THIS MIGHT refuse some code with FPU expression too complex
that were accepted before and even in some cases
that don't overflow in fact
( like if f : float; is a forward that finally in implementation
only uses one fpu register !!)
Nevertheless I think that it will improve security on
FPU operations !!
* most other changes only for UseBrowser code
(added symtable references for record and objects)
local switch for refs to args and local of each function
(static symtable still missing)
UseBrowser still not stable and probably broken by
the definition hash array !!
Revision 1.45 1998/09/18 09:58:51 peter
* -s doesn't require the .o to be available, this allows compiling of
everything on other platforms (profiling the windows.pp loading ;)
Revision 1.44 1998/09/10 13:51:32 peter
* tp compiler also uses 'as' as asmprefix
Revision 1.43 1998/09/03 17:08:45 pierre
* better lines for stabs
(no scroll back to if before else part
no return to case line at jump outside case)
+ source lines also if not in order
Revision 1.42 1998/09/03 11:24:00 peter
* moved more inputfile things from tscannerfile to tinputfile
* changed ifdef Sourceline to cs_asm_source
Revision 1.41 1998/08/26 15:35:30 peter
* fixed scannerfiles for macros
+ $I %<environment>%
Revision 1.40 1998/08/26 10:08:48 peter
* fixed problem with libprefix at the wrong place
* fixed lib generation with smartlinking and no -CS used
Revision 1.39 1998/08/25 16:44:16 pierre
* openppu was true even if the object file is missing
this lead to trying to open a filename without extension
and prevented the 'make cycle' to work for win32
Revision 1.38 1998/08/19 10:06:12 peter
* fixed filenames and removedir which supports slash at the end
Revision 1.37 1998/08/18 20:52:19 peter
* renamed in_main to in_global which is more logical
Revision 1.36 1998/08/17 10:10:07 peter
- removed OLDPPU
Revision 1.35 1998/08/17 09:17:44 peter
* static/shared linking updates
Revision 1.34 1998/08/14 21:56:31 peter
* setting the outputfile using -o works now to create static libs
Revision 1.33 1998/08/11 14:09:08 peter
* fixed some messages and smaller msgtxt.inc
Revision 1.32 1998/08/10 14:49:58 peter
+ localswitches, moduleswitches, globalswitches splitting
Revision 1.31 1998/07/14 14:46:48 peter
* released NEWINPUT
Revision 1.30 1998/07/07 11:19:55 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.29 1998/06/25 10:51:00 pierre
* removed a remaining ifndef NEWPPU
replaced by ifdef OLDPPU
* added uf_finalize to ppu unit
Revision 1.28 1998/06/25 08:48:12 florian
* first version of rtti support
Revision 1.27 1998/06/24 14:48:34 peter
* ifdef newppu -> ifndef oldppu
Revision 1.26 1998/06/17 14:36:19 peter
* forgot an $ifndef OLDPPU :(
Revision 1.25 1998/06/17 14:10:11 peter
* small os2 fixes
* fixed interdependent units with newppu (remake3 under linux works now)
Revision 1.24 1998/06/16 08:56:20 peter
+ targetcpu
* cleaner pmodules for newppu
Revision 1.23 1998/06/15 14:44:36 daniel
* BP updates.
Revision 1.22 1998/06/14 18:25:41 peter
* small fix with crc in newppu
Revision 1.21 1998/06/13 00:10:05 peter
* working browser and newppu
* some small fixes against crashes which occured in bp7 (but not in
fpc?!)
Revision 1.20 1998/06/12 14:50:48 peter
* removed the tree dependency to types.pas
* long_fil.pas support (not fully tested yet)
Revision 1.19 1998/06/12 10:32:26 pierre
* column problem hopefully solved
+ C vars declaration changed
Revision 1.18 1998/06/11 13:58:07 peter
* small fix to let newppu compile
Revision 1.17 1998/06/09 16:01:40 pierre
+ added procedure directive parsing for procvars
(accepted are popstack cdecl and pascal)
+ added C vars with the following syntax
var C calias 'true_c_name';(can be followed by external)
reason is that you must add the Cprefix
which is target dependent
Revision 1.16 1998/06/04 10:42:19 pierre
* small bug fix in load_ppu or openppu
Revision 1.15 1998/05/28 14:37:53 peter
* default programname is PROGRAM (like TP7) to avoid dup id's
Revision 1.14 1998/05/27 19:45:02 peter
* symtable.pas splitted into includefiles
* symtable adapted for $ifndef OLDPPU
Revision 1.13 1998/05/23 01:21:05 peter
+ aktasmmode, aktoptprocessor, aktoutputformat
+ smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+ $LIBNAME to set the library name where the unit will be put in
* splitted cgi386 a bit (codeseg to large for bp7)
* nasm, tasm works again. nasm moved to ag386nsm.pas
Revision 1.12 1998/05/20 09:42:33 pierre
+ UseTokenInfo now default
* unit in interface uses and implementation uses gives error now
* only one error for unknown symbol (uses lastsymknown boolean)
the problem came from the label code !
+ first inlined procedures and function work
(warning there might be allowed cases were the result is still wrong !!)
* UseBrower updated gives a global list of all position of all used symbols
with switch -gb
Revision 1.11 1998/05/12 10:46:59 peter
* moved printstatus to verb_def
+ V_Normal which is between V_Error and V_Warning and doesn't have a
prefix like error: warning: and is included in V_Default
* fixed some messages
* first time parameter scan is only for -v and -T
- removed old style messages
Revision 1.10 1998/05/11 13:07:53 peter
+ $ifndef OLDPPU for the new ppuformat
+ $define GDB not longer required
* removed all warnings and stripped some log comments
* no findfirst/findnext anymore to remove smartlink *.o files
Revision 1.9 1998/05/06 15:04:20 pierre
+ when trying to find source files of a ppufile
check the includepathlist for included files
the main file must still be in the same directory
Revision 1.8 1998/05/04 17:54:25 peter
+ smartlinking works (only case jumptable left todo)
* redesign of systems.pas to support assemblers and linkers
+ Unitname is now also in the PPU-file, increased version to 14
Revision 1.7 1998/05/01 16:38:44 florian
* handling of private and protected fixed
+ change_keywords_to_tp implemented to remove
keywords which aren't supported by tp
* break and continue are now symbols of the system unit
+ widestring, longstring and ansistring type released
Revision 1.6 1998/05/01 07:43:53 florian
+ basics for rtti implemented
+ switch $m (generate rtti for published sections)
Revision 1.5 1998/04/30 15:59:40 pierre
* GDB works again better :
correct type info in one pass
+ UseTokenInfo for better source position
* fixed one remaining bug in scanner for line counts
* several little fixes
Revision 1.4 1998/04/29 10:33:52 pierre
+ added some code for ansistring (not complete nor working yet)
* corrected operator overloading
* corrected nasm output
+ started inline procedures
+ added starstarn : use ** for exponentiation (^ gave problems)
+ started UseTokenInfo cond to get accurate positions
Revision 1.3 1998/04/27 23:10:28 peter
+ new scanner
* $makelib -> if smartlink
* small filename fixes pmodule.setfilename
* moved import from files.pas -> import.pas
Revision 1.2 1998/04/21 10:16:47 peter
* patches from strasbourg
* objects is not used anymore in the fpc compiled version
}