{
$Id: finput.pas,v 1.23 2003/12/27 22:27:24 peter Exp $
Copyright (c) 1998-2002 by Florian Klaempfl
This unit implements an extended file management
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 finput;
{$i fpcdefs.inc}
interface
uses
cutils,cclasses;
const
InputFileBufSize=32*1024;
linebufincrease=512;
type
tlongintarr = array[0..1000000] of longint;
plongintarr = ^tlongintarr;
tinputfile = class
path,name : pstring; { path and filename }
next : tinputfile; { next file for reading }
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_index : longint; { to handle the browser refs }
ref_next : tinputfile;
constructor create(const fn:string);
destructor destroy;override;
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;
function getfiletime:longint;
protected
filetime : longint;
function fileopen(const filename: string): boolean; virtual; abstract;
function fileseek(pos: longint): boolean; virtual; abstract;
function fileread(var databuf; maxsize: longint): longint; virtual; abstract;
function fileeof: boolean; virtual; abstract;
function fileclose: boolean; virtual; abstract;
procedure filegettime; virtual; abstract;
end;
tdosinputfile = class(tinputfile)
protected
function fileopen(const filename: string): boolean; override;
function fileseek(pos: longint): boolean; override;
function fileread(var databuf; maxsize: longint): longint; override;
function fileeof: boolean; override;
function fileclose: boolean; override;
procedure filegettime; override;
private
f : file; { current file handle }
end;
tinputfilemanager = class
files : tinputfile;
last_ref_index : longint;
cacheindex : longint;
cacheinputfile : tinputfile;
constructor create;
destructor destroy;override;
procedure register_file(f : tinputfile);
procedure inverse_register_indexes;
function get_file(l:longint) : tinputfile;
function get_file_name(l :longint):string;
function get_file_path(l :longint):string;
end;
{****************************************************************************
TModuleBase
****************************************************************************}
type
tmodulestate = (ms_unknown,
ms_registered,
ms_load,ms_compile,
ms_second_load,ms_second_compile,
ms_compiled
);
const
ModuleStateStr : array[TModuleState] of string[20] = (
'Unknown',
'Registered',
'Load','Compile',
'Second_Load','Second_Compile',
'Compiled'
);
type
tmodulebase = class(TLinkedListItem)
{ index }
unit_index : longint; { global counter for browser }
{ status }
state : tmodulestate;
{ sources }
sourcefiles : tinputfilemanager;
{ paths and filenames }
path, { path where the module is find/created }
outputpath, { path where the .s / .o / exe are created }
modulename, { name of the module in uppercase }
realmodulename, { name of the module in the orignal case }
objfilename, { fullname of the objectfile }
newfilename, { fullname of the assemblerfile }
ppufilename, { fullname of the ppufile }
staticlibfilename, { fullname of the static libraryfile }
sharedlibfilename, { fullname of the shared libraryfile }
mapfilename, { fullname of the mapfile }
exefilename, { fullname of the exefile }
mainsource : pstring; { name of the main sourcefile }
constructor create(const s:string);
destructor destroy;override;
procedure setfilename(const fn:string;allowoutput:boolean);
function get_asmfilename : string;
end;
implementation
uses
{$ifdef Delphi}
dmisc,
{$else Delphi}
dos,
{$endif Delphi}
{$ifdef heaptrc}
fmodule,
ppheap,
{$endif heaptrc}
globals,systems
;
{****************************************************************************
TINPUTFILE
****************************************************************************}
constructor tinputfile.create(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;
filetime:=-1;
{ 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_index:=0;
{ line buffer }
linebuf:=nil;
maxlinebuf:=0;
end;
destructor tinputfile.destroy;
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;
fileseek(fpos);
bufstart:=fpos;
bufsize:=0;
end;
procedure tinputfile.readbuf;
begin
if is_macro then
endoffile:=true;
if closed then
exit;
inc(bufstart,bufsize);
bufsize:=fileread(buf^,maxbufsize-1);
buf[bufsize]:=#0;
endoffile:=fileeof;
end;
function tinputfile.open:boolean;
begin
open:=false;
if not closed then
Close;
if not fileopen(path^+name^) then
exit;
{ file }
endoffile:=false;
closed:=false;
Getmem(buf,MaxBufsize);
bufstart:=0;
bufsize:=0;
open:=true;
end;
procedure tinputfile.close;
begin
if is_macro then
begin
if assigned(buf) then
begin
Freemem(buf,maxbufsize);
buf:=nil;
end;
closed:=true;
exit;
end;
if not closed then
begin
fileclose;
closed:=true;
end;
if assigned(buf) then
begin
Freemem(buf,maxbufsize);
buf:=nil;
end;
bufstart:=0;
end;
procedure tinputfile.tempclose;
begin
if is_macro then
exit;
if not closed then
begin
fileclose;
if assigned(buf) then
begin
Freemem(buf,maxbufsize);
buf:=nil;
end;
closed:=true;
end;
end;
function tinputfile.tempopen:boolean;
begin
tempopen:=false;
if is_macro then
begin
{ seek buffer postion to bufstart }
if bufstart>0 then
begin
move(buf[bufstart],buf[0],bufsize-bufstart+1);
bufstart:=0;
end;
tempopen:=true;
exit;
end;
if not closed then
exit;
if not fileopen(path^+name^) then
exit;
closed:=false;
{ get new mem }
Getmem(buf,maxbufsize);
{ restore state }
fileseek(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);
getlinestr[0]:=chr(i);
end;
end;
function tinputfile.getfiletime:longint;
begin
if filetime=-1 then
filegettime;
getfiletime:=filetime;
end;
{****************************************************************************
TDOSINPUTFILE
****************************************************************************}
function tdosinputfile.fileopen(const filename: string): boolean;
var
ofm : byte;
begin
{ Check if file exists, this will also check if it is
a real file and not a directory }
if not fileexists(filename) then
begin
result:=false;
exit;
end;
{ Open file }
ofm:=filemode;
filemode:=0;
Assign(f,filename);
{$I-}
reset(f,1);
{$I+}
filemode:=ofm;
fileopen:=(ioresult=0);
end;
function tdosinputfile.fileseek(pos: longint): boolean;
begin
{$I-}
seek(f,Pos);
{$I+}
fileseek:=(ioresult=0);
end;
function tdosinputfile.fileread(var databuf; maxsize: longint): longint;
var
w : longint;
begin
blockread(f,databuf,maxsize,w);
fileread:=w;
end;
function tdosinputfile.fileeof: boolean;
begin
fileeof:=eof(f);
end;
function tdosinputfile.fileclose: boolean;
begin
{$I-}
system.close(f);
{$I+}
fileclose:=(ioresult=0);
end;
procedure tdosinputfile.filegettime;
begin
filetime:=getnamedfiletime(path^+name^);
end;
{****************************************************************************
Tinputfilemanager
****************************************************************************}
constructor tinputfilemanager.create;
begin
files:=nil;
last_ref_index:=0;
cacheindex:=0;
cacheinputfile:=nil;
end;
destructor tinputfilemanager.destroy;
var
hp : tinputfile;
begin
hp:=files;
while assigned(hp) do
begin
files:=files.ref_next;
hp.free;
hp:=files;
end;
last_ref_index:=0;
end;
procedure tinputfilemanager.register_file(f : tinputfile);
begin
{ don't register macro's }
if f.is_macro then
exit;
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 heaptrc}
ppheap_register_file(f.name^,current_module.unit_index*100000+f.ref_index);
{$endif heaptrc}
end;
{ this procedure is necessary after loading the
sources files from a PPU file PM }
procedure tinputfilemanager.inverse_register_indexes;
var
f : tinputfile;
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 tinputfilemanager.get_file(l :longint) : tinputfile;
var
ff : tinputfile;
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 tinputfilemanager.get_file_name(l :longint):string;
var
hp : tinputfile;
begin
hp:=get_file(l);
if assigned(hp) then
get_file_name:=hp.name^
else
get_file_name:='';
end;
function tinputfilemanager.get_file_path(l :longint):string;
var
hp : tinputfile;
begin
hp:=get_file(l);
if assigned(hp) then
get_file_path:=hp.path^
else
get_file_path:='';
end;
{****************************************************************************
TModuleBase
****************************************************************************}
procedure tmodulebase.setfilename(const fn:string;allowoutput:boolean);
var
p : dirstr;
n : NameStr;
e : ExtStr;
begin
stringdispose(objfilename);
stringdispose(newfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(mapfilename);
stringdispose(exefilename);
stringdispose(outputpath);
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;
outputpath:=stringdup(p);
newfilename := stringdup(n);
objfilename:=stringdup(p+n+target_info.objext);
ppufilename:=stringdup(p+n+target_info.unitext);
{ lib and exe could be loaded with a file specified with -o }
if AllowOutput and (OutputFile<>'') and (compile_level=1) then
n:=OutputFile;
staticlibfilename:=stringdup(p+target_info.staticlibprefix+n+target_info.staticlibext);
{ output dir of exe can be specified separatly }
if AllowOutput and (OutputExeDir<>'') then
p:=OutputExeDir
else
p:=path^;
if target_info.system in [system_i386_WIN32,system_i386_wdosx] then
sharedlibfilename:=stringdup(p+n+target_info.sharedlibext)
else
sharedlibfilename:=stringdup(p+target_info.sharedlibprefix+n+target_info.sharedlibext);
exefilename:=stringdup(p+n+target_info.exeext);
mapfilename:=stringdup(p+n+'.map');
end;
constructor tmodulebase.create(const s:string);
begin
modulename:=stringdup(Upper(s));
realmodulename:=stringdup(s);
mainsource:=nil;
ppufilename:=nil;
objfilename:=nil;
newfilename:=nil;
staticlibfilename:=nil;
sharedlibfilename:=nil;
exefilename:=nil;
mapfilename:=nil;
outputpath:=nil;
path:=nil;
{ status }
state:=ms_registered;
{ unit index }
inc(global_unit_count);
unit_index:=global_unit_count;
{ sources }
sourcefiles:=TInputFileManager.Create;
end;
function tmodulebase.get_asmfilename : string;
begin
get_asmfilename:=outputpath^+newfilename^+target_info.asmext;
end;
destructor tmodulebase.destroy;
begin
if assigned(sourcefiles) then
sourcefiles.free;
sourcefiles:=nil;
stringdispose(objfilename);
stringdispose(newfilename);
stringdispose(ppufilename);
stringdispose(staticlibfilename);
stringdispose(sharedlibfilename);
stringdispose(exefilename);
stringdispose(mapfilename);
stringdispose(outputpath);
stringdispose(path);
stringdispose(modulename);
stringdispose(realmodulename);
stringdispose(mainsource);
inherited destroy;
end;
end.
{
$Log: finput.pas,v $
Revision 1.23 2003/12/27 22:27:24 peter
* check with fileexists() before opening a file
Revision 1.22 2003/04/28 16:18:16 peter
* sharedlib is placed in exe outputdir
Revision 1.21 2002/12/29 14:57:50 peter
* unit loading changed to first register units and load them
afterwards. This is needed to support uses xxx in yyy correctly
* unit dependency check fixed
Revision 1.20 2002/11/15 01:58:46 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.19 2002/10/20 14:49:31 peter
* store original source time in ppu so it can be compared instead of
comparing with the ppu time
Revision 1.18 2002/08/11 13:24:11 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.17 2002/07/26 21:15:37 florian
* rewrote the system handling
Revision 1.16 2002/07/01 18:46:22 peter
* internal linker
* reorganized aasm layer
Revision 1.15 2002/05/18 13:34:07 peter
* readded missing revisions
Revision 1.14 2002/05/16 19:46:36 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.13 2002/05/14 19:34:41 peter
* removed old logs and updated copyright year
Revision 1.12 2002/04/04 18:34:00 carl
+ added wdosx support (patch from Pavel)
}
syntax highlighted by Code2HTML, v. 0.9.1