paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-06 18:32:32 +02:00
Code Issues Packages Projects Releases Wiki Activity
f002eb11a0
fpc/compiler/files.pas
peter f002eb11a0 * fixed problem with libprefix at the wrong place 
* fixed lib generation with smartlinking and no -CS used
1998-08-26 10:08:47 +00:00

826 lines
26 KiB
ObjectPascal
Raw Blame History

{
$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;
interface
uses
cobjects,globals,ppu;
const
{$ifdef FPC}
maxunits = 1024;
extbufsize = 65535;
{$else}
maxunits = 128;
extbufsize=1024;
{$endif}
type
pinputfile = ^tinputfile;
tinputfile = object
path,name : pstring; { path and filename }
next : pinputfile; { next file for reading }
savebufstart, { save fields for scanner }
savebufsize,
savelastlinepos,
saveline_no : longint;
saveinputbuffer,
saveinputpointer : pchar;
linebuf : plongint; { 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;
{$ifdef SourceLine}
function getlinestr(l:longint):string;
{$endif SourceLine}
end;
pfilemanager = ^tfilemanager;
tfilemanager = object
files : pinputfile;
last_ref_index : longint;
constructor init;
destructor done;
procedure register_file(f : pinputfile);
function get_file(l:longint) : pinputfile;
function get_file_name(l :longint):string;
function get_file_path(l :longint):string;
end;
type
tunitmap = array[0..maxunits-1] of pointer;
punitmap = ^tunitmap;
pmodule = ^tmodule;
tmodule = object(tlinkedlist_item)
ppufile : pppufile; { the PPU file }
crc,
flags : longint; { the PPU flags }
compiled, { unit is already compiled }
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_implementation, { processing the implementation part? }
in_global : boolean; { allow global settings }
map : punitmap; { mapping of all used units }
unitcount : word; { local unit counter }
unit_index : word; { global counter for browser }
symtable : pointer; { pointer to the psymtable of this unit }
uses_imports : boolean; { Set if the module imports from DLL's.}
imports : plinkedlist;
sourcefiles : tfilemanager;
linksharedlibs,
linkstaticlibs,
linkofiles : tstringcontainer;
used_units : tlinkedlist;
{ used in firstpass for faster settings }
scanner : pointer;
current_index : word;
path, { path where the module is find/created }
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 }
constructor init(const s:string;_is_unit:boolean);
destructor done;virtual;
procedure setfilename(const fn:string);
function openppu:boolean;
function search_unit(const n : string):boolean;
end;
pused_unit = ^tused_unit;
tused_unit = object(tlinkedlist_item)
unitid : word;
name : pstring;
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:longint;intface:boolean);
destructor done;virtual;
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 }
implementation
uses
dos,verbose,systems;
{****************************************************************************
TINPUTFILE
****************************************************************************}
constructor tinputfile.init(const fn:string);
var
p,n,e : string;
begin
FSplit(fn,p,n,e);
name:=stringdup(n+e);
path:=stringdup(p);
next:=nil;
{ indexing refs }
ref_next:=nil;
ref_count:=0;
ref_index:=0;
{$ifdef SourceLine}
{ line buffer }
linebuf:=nil;
maxlinebuf:=0;
{$endif SourceLine}
end;
destructor tinputfile.done;
begin
stringdispose(path);
stringdispose(name);
{$ifdef SourceLine}
{ free memory }
if assigned(linebuf) then
freemem(linebuf,maxlinebuf shl 2);
{$endif SourceLine}
end;
{$ifdef SourceLine}
function tinputfile.getlinestr(l:longint):string;
var
c : char;
i,fpos : longint;
begin
getlinestr:='';
if l<maxlinebuf then
begin
fpos:=plongint(longint(linebuf)+line_no*2)^;
{ 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;
inputpointer:=inputbuffer;
c:=inputpointer^;
while (i<255) and not(c in [#13,#10]) do
begin
inc(i);
getlinestr[i]:=c;
c:=inputpointer^;
if c=#0 then
reload
else
inc(longint(inputpointer));
end;
getlinestr[0]:=chr(i);
end;
end;
{$endif SourceLine}
{****************************************************************************
TFILEMANAGER
****************************************************************************}
constructor tfilemanager.init;
begin
files:=nil;
last_ref_index:=0;
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;
end;
function tfilemanager.get_file(l :longint) : pinputfile;
var
ff : pinputfile;
begin
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;
{****************************************************************************
TMODULE
****************************************************************************}
procedure tmodule.setfilename(const fn:string);
var
p : dirstr;
n : NameStr;
e : ExtStr;
begin
stringdispose(objfilename);
stringdispose(asmfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(exefilename);
stringdispose(path);
{ Create names }
fsplit(fn,p,n,e);
p:=FixPath(p);
n:=FixFileName(n);
{ set path and obj,asm,ppu names }
path:=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 OutputFile<>'' then
n:=OutputFile;
staticlibfilename:=stringdup(p+target_os.libprefix+n+target_os.staticlibext);
sharedlibfilename:=stringdup(p+target_os.libprefix+n+target_os.sharedlibext);
exefilename:=stringdup(p+n+target_os.exeext);
end;
function tmodule.openppu:boolean;
var
objfiletime,
ppufiletime,
asmfiletime : longint;
begin
openppu:=false;
{ Get ppufile time (also check if the file exists) }
ppufiletime:=getnamedfiletime(ppufilename^);
if ppufiletime=-1 then
exit;
{ Open the ppufile }
Message1(unit_u_ppu_loading,ppufilename^);
ppufile:=new(pppufile,init(ppufilename^));
if not ppufile^.open then
begin
dispose(ppufile,done);
Message(unit_d_ppu_file_too_short);
exit;
end;
{ check for a valid PPU file }
if not ppufile^.CheckPPUId then
begin
dispose(ppufile,done);
Message(unit_d_ppu_invalid_header);
exit;
end;
{ check for allowed PPU versions }
if not (ppufile^.GetPPUVersion in [15]) then
begin
dispose(ppufile,done);
Message1(unit_d_ppu_invalid_version,tostr(ppufile^.GetPPUVersion));
exit;
end;
{ check the target processor }
if ttargetcpu(ppufile^.header.cpu)<>target_cpu then
begin
dispose(ppufile,done);
Comment(V_Debug,'unit is compiled for an other processor');
exit;
end;
{ check target }
if ttarget(ppufile^.header.target)<>target_info.target then
begin
dispose(ppufile,done);
Comment(V_Debug,'unit is compiled for an other target');
exit;
end;
{!!!!!!!!!!!!!!!!!!! }
{ Load values to be access easier }
flags:=ppufile^.header.flags;
crc:=ppufile^.header.checksum;
{ Show Debug info }
Message1(unit_d_ppu_time,filetimestring(ppufiletime));
Message1(unit_d_ppu_flags,tostr(flags));
Message1(unit_d_ppu_crc,tostr(ppufile^.header.checksum));
{ 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_static_linked)<>0) or
((flags and uf_smartlink)<>0) then
begin
objfiletime:=getnamedfiletime(staticlibfilename^);
if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
do_compile:=true;
end
else
if (flags and uf_shared_linked)<>0 then
begin
objfiletime:=getnamedfiletime(sharedlibfilename^);
if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
do_compile:=true;
end
else
begin
{ the objectfile should be newer than the ppu file }
objfiletime:=getnamedfiletime(objfilename^);
if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
begin
{ check if assembler file is older than ppu file }
asmfileTime:=GetNamedFileTime(asmfilename^);
if (asmfiletime<0) or (ppufiletime>asmfiletime) then
begin
Message(unit_d_obj_and_asm_are_older_than_ppu);
do_compile:=true;
{ we should try to get the source file }
exit;
end
else
begin
Message(unit_d_obj_is_older_than_asm);
exit;
end;
end;
end;
end;
openppu:=true;
end;
function tmodule.search_unit(const n : string):boolean;
var
ext : string[8];
singlepathstring,
unitPath,
filename : string;
found : boolean;
start,i : longint;
Function UnitExists(const ext:string):boolean;
begin
Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
UnitExists:=FileExists(Singlepathstring+FileName+ext);
end;
begin
start:=1;
filename:=FixFileName(n);
unitpath:=UnitSearchPath;
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));
delete(unitpath,start,i-start+1);
{ Check for PPL file }
if not Found then
begin
Found:=UnitExists(target_info.unitlibext);
if Found then
Begin
SetFileName(SinglePathString+FileName);
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);
Found:=OpenPPU;
End;
end;
{ Check for Sources }
if not Found then
begin
ppufile:=nil;
do_compile:=true;
{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);
end
else
sources_avail:=false;
end;
until Found or (unitpath='');
search_unit:=Found;
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;
{ go32v2 has the famous 8.3 limit ;) }
{$ifdef go32v2}
asmprefix:=stringdup(FixFileName('as'));
{$else}
asmprefix:=stringdup(FixFileName(n));
{$endif}
path:=nil;
setfilename(p+n);
used_units.init;
sourcefiles.init;
linkofiles.init;
linkstaticlibs.init;
linksharedlibs.init;
current_index:=0;
ppufile:=nil;
scanner:=nil;
map:=nil;
symtable:=nil;
flags:=0;
crc:=0;
unitcount:=1;
inc(global_unit_count);
unit_index:=global_unit_count;
do_assemble:=false;
do_compile:=false;
sources_avail:=true;
compiled:=false;
in_implementation:=false;
in_global:=true;
is_unit:=_is_unit;
uses_imports:=false;
imports:=new(plinkedlist,init);
{ set smartlink flag }
if (cs_smartlink in aktmoduleswitches) then
flags:=flags or uf_smartlink;
{ search the PPU file if it is an unit }
if is_unit then
begin
if (not search_unit(modulename^)) and (length(modulename^)>8) then
search_unit(copy(modulename^,1,8));
end;
end;
destructor tmodule.done;
begin
if assigned(map) then
dispose(map);
if assigned(ppufile) then
dispose(ppufile,done);
if assigned(imports) then
dispose(imports,done);
used_units.done;
sourcefiles.done;
linkofiles.done;
linkstaticlibs.done;
linksharedlibs.done;
stringdispose(objfilename);
stringdispose(asmfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(exefilename);
stringdispose(path);
stringdispose(modulename);
stringdispose(mainsource);
stringdispose(asmprefix);
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;
unitid:=0;
end;
constructor tused_unit.init_to_load(const n:string;c:longint;intface:boolean);
begin
u:=nil;
in_interface:=intface;
in_uses:=false;
is_stab_written:=false;
loaded:=false;
name:=stringdup(n);
checksum:=c;
unitid:=0;
end;
destructor tused_unit.done;
begin
stringdispose(name);
inherited done;
end;
end.
{
$Log$
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
}
Reference in New Issue View Git Blame Copy Permalink