paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-02 22:55:22 +02:00
Code Issues Packages Projects Releases Wiki Activity
1610a9d709
fpc/compiler/globals.pas
peter 503d5a1cfa * const parameter is now checked 
* better and generic check if a node can be used for assigning
  * export fixes
  * procvar equal works now (it never had worked at least from 0.99.8)
  * defcoll changed to linkedlist with pparaitem so it can easily be
    walked both directions
1999-10-26 12:30:40 +00:00

1893 lines
51 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (C) 1993-98 by Florian Klaempfl
This unit implements some support functions and global variables
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.
****************************************************************************
}
{$ifdef tp}
{$E+,N+}
{$endif}
unit globals;
interface
uses
{$ifdef Delphi4}
dmisc,
sysutils,
{$else}
strings,dos,
{$endif}
{$ifdef linux}
{$ifdef TP}
objects,
{$endif}
linux,
{$endif}
globtype,version,tokens,systems,cobjects;
const
{$ifdef linux}
DirSep = '/';
{$else}
{$ifdef amiga}
DirSep = '/';
{$else}
DirSep = '\';
{$endif}
{$endif}
{$ifdef Splitheap}
testsplit : boolean = false;
{$endif Splitheap}
delphimodeswitches : tmodeswitches=
[m_delphi,m_tp,m_all,m_class,m_objpas,m_result,m_string_pchar,
m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal];
fpcmodeswitches : tmodeswitches=
[m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward,
m_cvar_support,m_initfinal,m_add_pointer];
objfpcmodeswitches : tmodeswitches=
[m_fpc,m_all,m_class,m_objpas,m_result,m_string_pchar,m_nested_comment,
m_repeat_forward,m_cvar_support,m_initfinal,m_add_pointer];
tpmodeswitches : tmodeswitches=
[m_tp,m_all,m_tp_procvar];
gpcmodeswitches : tmodeswitches=
[m_gpc,m_all];
var
{ specified inputfile }
inputdir : dirstr;
inputfile : namestr;
inputextension : extstr;
{ specified outputfile with -o parameter }
outputfile : namestr;
{ specified with -FE or -FU }
outputexedir : dirstr;
outputunitdir : dirstr;
{ things specified with parameters }
paralinkoptions,
paradynamiclinker : string;
{ directory where the utils can be found (options -FD) }
utilsdirectory : dirstr;
{ some flags for global compiler switches }
do_build,
do_make : boolean;
not_unit_proc : boolean;
{ path for searching units, different paths can be seperated by ; }
exepath : dirstr; { Path to ppc }
librarysearchpath,
unitsearchpath,
objectsearchpath,
includesearchpath : string;
{ deffile }
usewindowapi : boolean;
description : string;
{ current position }
token, { current token being parsed }
idtoken : ttoken; { holds the token if the pattern is a known word }
tokenpos, { last postion of the read token }
aktfilepos : tfileposinfo; { current position }
{ type of currently parsed block }
{ isn't full implemented (FK) }
block_type : tblock_type;
in_args : boolean; { arguments must be checked especially }
parsing_para_level : longint; { parameter level, used to convert
proc calls to proc loads in firstcalln }
Must_be_valid : boolean; { should the variable already have a value }
compile_level : word;
make_ref : boolean;
use_esp_stackframe : boolean; { to test for call with ESP as stack frame }
{$ifdef TP}
use_big : boolean;
{$endif}
{ commandline values }
initdefines : tlinkedlist;
initglobalswitches : tglobalswitches;
initmoduleswitches : tmoduleswitches;
initlocalswitches : tlocalswitches;
initmodeswitches : tmodeswitches;
initpackenum : longint;
initpackrecords : tpackrecords;
initoutputformat : tasm;
initoptprocessor : tprocessors;
initasmmode : tasmmode;
{ current state values }
aktglobalswitches : tglobalswitches;
aktmoduleswitches : tmoduleswitches;
aktlocalswitches : tlocalswitches;
aktmodeswitches : tmodeswitches;
aktpackenum : longint;
aktpackrecords : tpackrecords;
aktoutputformat : tasm;
aktoptprocessor : tprocessors;
aktasmmode : tasmmode;
{ Memory sizes }
heapsize,
maxheapsize,
stacksize : longint;
{$Ifdef EXTDEBUG}
total_of_firstpass,
firstpass_several : longint;
{$ifdef FPC}
EntryMemUsed : longint;
{$endif FPC}
{ parameter switches }
debugstop,
only_one_pass : boolean;
{$EndIf EXTDEBUG}
{ windows application type }
apptype : tapptype;
const
RelocSection : boolean = true;
DLLsource : boolean = false;
DLLImageBase : pstring = nil;
{ used to set all registers used for each global function
this should dramatically decrease the number of
recompilations needed PM }
simplify_ppu : boolean = false;
{ should we allow non static members ? }
allow_only_static : boolean = false;
Inside_asm_statement : boolean = false;
{ for error info in pp.pas }
const
parser_current_file : string = '';
{$ifdef debug}
{ if the pointer don't point to the heap then write an error }
function assigned(p : pointer) : boolean;
{$endif}
function min(a,b : longint) : longint;
function max(a,b : longint) : longint;
function align(i,a:longint):longint;
procedure Replace(var s:string;s1:string;const s2:string);
procedure ReplaceCase(var s:string;const s1,s2:string);
function upper(const s : string) : string;
function lower(const s : string) : string;
function trimspace(const s:string):string;
{$ifdef FPC}
function tostru(i:cardinal) : string;
{$else}
function tostru(i:longint) : string;
{$endif}
procedure uppervar(var s : string);
function tostr(i : longint) : string;
function tostr_with_plus(i : longint) : string;
procedure valint(S : string;var V : longint;var code : integer);
function is_number(const s : string) : boolean;
function ispowerof2(value : longint;var power : longint) : boolean;
{ enable ansistring comparison }
function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
function bstoslash(const s : string) : string;
procedure abstract;
function getdatestr:string;
function gettimestr:string;
function filetimestring( t : longint) : string;
procedure DefaultReplacements(var s:string);
function path_absolute(const s : string) : boolean;
Function FileExists ( Const F : String) : Boolean;
Function RemoveFile(const f:string):boolean;
Function RemoveDir(d:string):boolean;
Function GetFileTime ( Var F : File) : Longint;
Function GetNamedFileTime ( Const F : String) : Longint;
Function SplitFileName(const s:string):string;
Function SplitName(const s:string):string;
Function SplitExtension(Const HStr:String):String;
Function AddExtension(Const HStr,ext:String):String;
Function ForceExtension(Const HStr,ext:String):String;
Function FixPath(s:string;allowdot:boolean):string;
function FixFileName(const s:string):string;
procedure SplitBinCmd(const s:string;var bstr,cstr:string);
procedure AddPathToList(var list:string;s:string;first:boolean);
function getpathfromlist(var list:string):string;
function search(const f : string;path : string;var b : boolean) : string;
procedure SynchronizeFileTime(const fn1,fn2:string);
function FindExe(bin:string;var found:boolean):string;
Procedure Shell(const command:string);
procedure InitGlobals;
procedure DoneGlobals;
procedure strdispose(var p : pchar);
implementation
uses
comphook;
procedure strdispose(var p : pchar);
begin
if assigned(p) then
begin
freemem(p,strlen(p)+1);
p:=nil;
end;
end;
function ngraphsearchvalue(const s1,s2 : string) : double;
const
n = 3;
var
equals,i,j : longint;
hs : string;
begin
equals:=0;
{ is the string long enough ? }
if min(length(s1),length(s2))-n+1<1 then
begin
ngraphsearchvalue:=0.0;
exit;
end;
for i:=1 to length(s1)-n+1 do
begin
hs:=copy(s1,i,n);
for j:=1 to length(s2)-n+1 do
if hs=copy(s2,j,n) then
inc(equals);
end;
{$ifdef fpc}
ngraphsearchvalue:=equals/double(max(length(s1),length(s2))-n+1);
{$else}
ngraphsearchvalue:=equals/(max(length(s1),length(s2))-n+1);
{$endif}
end;
function bstoslash(const s : string) : string;
{
return string s with all \ changed into /
}
var
i : longint;
begin
for i:=1to length(s) do
if s[i]='\' then
bstoslash[i]:='/'
else
bstoslash[i]:=s[i];
{$ifndef TP}
{$ifopt H+}
setlength(bstoslash,length(s));
{$else}
bstoslash[0]:=s[0];
{$endif}
{$else}
bstoslash[0]:=s[0];
{$endif}
end;
{$ifdef debug}
function assigned(p : pointer) : boolean;
type
ptrrec = record
ofs,seg : word;
end;
{$ifndef FPC}
{$ifndef DPMI}
var
lp : longint;
{$endif DPMI}
{$endif FPC}
begin
{$ifdef FPC}
{ Assigned is used for procvar and
stack stored temp records !! PM }
(* if (p<>nil) {and
((p<heaporg) or
(p>heapptr))} then
do_internalerror(230); *)
{$else}
{$ifdef DPMI}
assigned:=(p<>nil);
exit;
{$else DPMI}
if p=nil then
lp:=0
else
lp:=longint(ptrrec(p).seg)*16+longint(ptrrec(p).ofs);
if (lp<>0) and
((lp<longint(seg(heaporg^))*16+longint(ofs(heaporg^))) or
(lp>longint(seg(heapptr^))*16+longint(ofs(heapptr^)))) then
do_internalerror(230);
{$endif DPMI}
{$endif FPC}
assigned:=(p<>nil);
end;
{$endif}
function min(a,b : longint) : longint;
{
return the minimal of a and b
}
begin
if a>b then
min:=b
else
min:=a;
end;
function max(a,b : longint) : longint;
{
return the maximum of a and b
}
begin
if a<b then
max:=b
else
max:=a;
end;
function align(i,a:longint):longint;
{
return value <i> aligned <a> boundary
}
begin
align:=(i+a-1) and not(a-1);
end;
procedure Replace(var s:string;s1:string;const s2:string);
var
last,
i : longint;
begin
s1:=upper(s1);
last:=0;
repeat
i:=pos(s1,upper(s));
if i=last then
i:=0;
if (i>0) then
begin
Delete(s,i,length(s1));
Insert(s2,s,i);
last:=i;
end;
until (i=0);
end;
procedure ReplaceCase(var s:string;const s1,s2:string);
var
last,
i : longint;
begin
last:=0;
repeat
i:=pos(s1,s);
if i=last then
i:=0;
if (i>0) then
begin
Delete(s,i,length(s1));
Insert(s2,s,i);
last:=i;
end;
until (i=0);
end;
function upper(const s : string) : string;
{
return uppercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
{$ifdef FPC}
{$ifopt H+}
setlength(upper,length(s));
{$else}
upper[0]:=s[0];
{$endif}
{$else}
upper[0]:=s[0];
{$endif}
end;
function lower(const s : string) : string;
{
return lowercased string of s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['A'..'Z'] then
lower[i]:=char(byte(s[i])+32)
else
lower[i]:=s[i];
{$ifndef TP}
{$ifopt H+}
setlength(lower,length(s));
{$else}
lower[0]:=s[0];
{$endif}
{$else}
lower[0]:=s[0];
{$endif}
end;
procedure uppervar(var s : string);
{
uppercase string s
}
var
i : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
s[i]:=char(byte(s[i])-32);
end;
{$ifdef FPC}
function tostru(i:cardinal):string;
{
return string of value i, but for cardinals
}
var hs:string;
begin
str(i,hs);
tostru:=hs;
end;
{$else FPC}
function tostru(i:longint):string;
begin
tostru:=tostr(i);
end;
{$endif FPC}
function trimspace(const s:string):string;
{
return s with all leading and ending spaces and tabs removed
}
var
i,j : longint;
begin
i:=length(s);
while (i>0) and (s[i] in [#9,' ']) do
dec(i);
j:=1;
while (j<i) and (s[j] in [#9,' ']) do
inc(j);
trimspace:=Copy(s,j,i-j+1);
end;
function tostr(i : longint) : string;
{
return string of value i
}
var
hs : string;
begin
str(i,hs);
tostr:=hs;
end;
function tostr_with_plus(i : longint) : string;
{
return string of value i, but always include a + when i>=0
}
var
hs : string;
begin
str(i,hs);
if i>=0 then
tostr_with_plus:='+'+hs
else
tostr_with_plus:=hs;
end;
procedure valint(S : string;var V : longint;var code : integer);
{
val() with support for octal, which is not supported under tp7
}
{$ifndef FPC}
var
vs : longint;
c : byte;
begin
if s[1]='%' then
begin
vs:=0;
longint(v):=0;
for c:=2 to length(s) do
begin
if s[c]='0' then
vs:=vs shl 1
else
if s[c]='1' then
vs:=vs shl 1+1
else
begin
code:=c;
exit;
end;
end;
code:=0;
longint(v):=vs;
end
else
system.val(S,V,code);
end;
{$else not FPC}
begin
system.val(S,V,code);
end;
{$endif not FPC}
function is_number(const s : string) : boolean;
{
is string a correct number ?
}
var
w : integer;
l : longint;
begin
valint(s,l,w);
is_number:=(w=0);
end;
function ispowerof2(value : longint;var power : longint) : boolean;
{
return if value is a power of 2. And if correct return the power
}
var
hl : longint;
i : longint;
begin
hl:=1;
ispowerof2:=true;
for i:=0 to 31 do
begin
if hl=value then
begin
power:=i;
exit;
end;
hl:=hl shl 1;
end;
ispowerof2:=false;
end;
{ enable ansistring comparison }
{ 0 means equal }
{ 1 means p1 > p2 }
{ -1 means p1 < p2 }
function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
var
i,j : longint;
begin
compareansistrings:=0;
j:=min(length1,length2);
i:=0;
while (i<j) do
begin
if p1[i]>p2[i] then
begin
compareansistrings:=1;
exit;
end
else
if p1[i]<p2[i] then
begin
compareansistrings:=-1;
exit;
end;
inc(i);
end;
if length1>length2 then
compareansistrings:=1
else
if length1<length2 then
compareansistrings:=-1;
end;
function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
var
p : pchar;
begin
getmem(p,length1+length2+1);
move(p1[0],p[0],length1);
move(p2[0],p[length1],length2+1);
concatansistrings:=p;
end;
{****************************************************************************
Time Handling
****************************************************************************}
Function L0(l:longint):string;
{
return the string of value l, if l<10 then insert a zero, so
the string is always at least 2 chars '01','02',etc
}
var
s : string;
begin
Str(l,s);
if l<10 then
s:='0'+s;
L0:=s;
end;
function gettimestr:string;
{
get the current time in a string HH:MM:SS
}
var
hour,min,sec,hsec : word;
begin
{$ifdef delphi}
dmisc.gettime(hour,min,sec,hsec);
{$else delphi}
dos.gettime(hour,min,sec,hsec);
{$endif delphi}
gettimestr:=L0(Hour)+':'+L0(min)+':'+L0(sec);
end;
function getdatestr:string;
{
get the current date in a string YY/MM/DD
}
var
Year,Month,Day,Wday : Word;
begin
{$ifdef delphi}
dmisc.getdate(year,month,day,wday);
{$else}
dos.getdate(year,month,day,wday);
{$endif}
getdatestr:=L0(Year)+'/'+L0(Month)+'/'+L0(Day);
end;
function filetimestring( t : longint) : string;
{
convert dos datetime t to a string YY/MM/DD HH:MM:SS
}
var
{$ifndef linux}
DT : DateTime;
{$endif}
Year,Month,Day,Hour,Min,Sec : Word;
begin
if t=-1 then
begin
FileTimeString:='Not Found';
exit;
end;
{$ifndef linux}
unpacktime(t,DT);
Year:=dT.year;month:=dt.month;day:=dt.day;
Hour:=dt.hour;min:=dt.min;sec:=dt.sec;
{$else}
EpochToLocal (t,year,month,day,hour,min,sec);
{$endif}
filetimestring:=L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
end;
{****************************************************************************
Default Macro Handling
****************************************************************************}
procedure DefaultReplacements(var s:string);
begin
{ Replace some macro's }
Replace(s,'$FPCVER',full_version_string);
Replace(s,'$FPCDATE',date_string);
Replace(s,'$FPCTARGET',target_cpu_string);
Replace(s,'$FPCCPU',target_cpu_string);
Replace(s,'$TARGET',target_path);
Replace(s,'$FPCOS',target_path);
end;
{****************************************************************************
File Handling
****************************************************************************}
function path_absolute(const s : string) : boolean;
{
is path s an absolute path?
}
begin
path_absolute:=false;
{$ifdef linux}
if (length(s)>0) and (s[1]='/') then
path_absolute:=true;
{$else linux}
{$ifdef amiga}
if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
path_absolute:=true;
{$else}
if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
path_absolute:=true;
{$endif amiga}
{$endif linux}
end;
{$ifndef FPC}
Procedure FindClose(var Info : SearchRec);
Begin
End;
{$endif not FPC}
{$ifdef delphi}
Function FileExists ( Const F : String) : Boolean;
begin
FileExists:=sysutils.FileExists(f);
end;
{$else}
Function FileExists ( Const F : String) : Boolean;
Var
{$ifdef linux}
Info : Stat;
{$else}
Info : SearchRec;
{$endif}
begin
{$ifdef linux}
FileExists:=FStat(F,info);
{$else}
findfirst(F,readonly+archive+hidden,info);
FileExists:=(doserror=0);
findclose(Info);
{$endif}
end;
{$endif}
Function RemoveFile(const f:string):boolean;
var
g : file;
begin
assign(g,f);
{$I-}
erase(g);
{$I+}
RemoveFile:=(ioresult=0);
end;
Function RemoveDir(d:string):boolean;
begin
if d[length(d)]=DirSep then
Delete(d,length(d),1);
{$I-}
rmdir(d);
{$I+}
RemoveDir:=(ioresult=0);
end;
Function SplitFileName(const s:string):string;
var
p : dirstr;
n : namestr;
e : extstr;
begin
FSplit(s,p,n,e);
SplitFileName:=n+e;
end;
Function SplitName(const s:string):string;
var
i,j : longint;
begin
i:=Length(s);
j:=Length(s);
while (i>0) and not(s[i] in ['/','\']) do
dec(i);
while (j>0) and (s[j]<>'.') do
dec(j);
if j<=i then
j:=255;
SplitName:=Copy(s,i+1,j-(i+1));
end;
Function SplitExtension(Const HStr:String):String;
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
begin
if hstr[j]=DirSep then
j:=0
else
dec(j);
end;
if j=0 then
j:=254;
SplitExtension:=Copy(Hstr,j,255);
end;
Function AddExtension(Const HStr,ext:String):String;
begin
if (Ext<>'') and (SplitExtension(HStr)='') then
AddExtension:=Hstr+Ext
else
AddExtension:=Hstr;
end;
Function ForceExtension(Const HStr,ext:String):String;
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
j:=255;
ForceExtension:=Copy(Hstr,1,j-1)+Ext;
end;
Function FixPath(s:string;allowdot:boolean):string;
var
i : longint;
begin
{ Fix separator }
for i:=1 to length(s) do
if s[i] in ['/','\'] then
s[i]:=DirSep;
{ Fix ending / }
if (length(s)>0) and (s[length(s)]<>DirSep) and
(s[length(s)]<>':') then
s:=s+DirSep;
{ Remove ./ }
if (not allowdot) and (s='.'+DirSep) then
s:='';
{ return }
FixPath:=s;
end;
function FixFileName(const s:string):string;
var
i : longint;
NoPath : boolean;
begin
NoPath:=true;
for i:=length(s) downto 1 do
begin
case s[i] of
{$ifdef Linux}
'/','\' : begin
FixFileName[i]:='/';
NoPath:=false; {Skip lowercasing path: 'X11'<>'x11' }
end;
'A'..'Z' : if NoPath then
FixFileName[i]:=char(byte(s[i])+32)
else
FixFileName[i]:=s[i];
{$else}
'/' : FixFileName[i]:='\';
'A'..'Z' : FixFileName[i]:=char(byte(s[i])+32);
{$endif}
else
FixFileName[i]:=s[i];
end;
end;
{$ifndef TP}
{$ifopt H+}
SetLength(FixFileName,length(s));
{$else}
FixFileName[0]:=s[0];
{$endif}
{$else}
FixFileName[0]:=s[0];
{$endif}
end;
procedure SplitBinCmd(const s:string;var bstr,cstr:string);
var
i : longint;
begin
i:=pos(' ',s);
if i>0 then
begin
bstr:=Copy(s,1,i-1);
cstr:=Copy(s,i+1,length(s)-i);
end
else
begin
bstr:='';
cstr:='';
end;
end;
procedure AddPathToList(var list:string;s:string;first:boolean);
var
LastAdd,
starti,i,j : longint;
Found : boolean;
CurrentDir,
CurrPath,
AddList : string;
begin
if s='' then
exit;
{ Support default macro's }
DefaultReplacements(s);
{ Fix List }
if (length(list)>0) and (list[length(list)]<>';') then
list:=list+';';
GetDir(0,CurrentDir);
CurrentDir:=FixPath(CurrentDir,false);
AddList:='';
LastAdd:=1;
repeat
j:=Pos(';',s);
if j=0 then
j:=255;
{Get Pathname}
CurrPath:=FixPath(Copy(s,1,j-1),false);
if CurrPath='' then
CurrPath:='.'+DirSep+';'
else
begin
CurrPath:=FixPath(FExpand(CurrPath),false)+';';
if (Copy(CurrPath,1,length(CurrentDir))=CurrentDir) then
CurrPath:='.'+DirSep+Copy(CurrPath,length(CurrentDir)+1,255);
end;
Delete(s,1,j);
{Check if already in path}
found:=false;
i:=0;
starti:=1;
while (not found) and (i<length(list)) do
begin
inc(i);
if (list[i]=';') then
begin
found:=(CurrPath=Copy(List,starti,i-starti+1));
if Found then
begin
if First then
Delete(List,Starti,i-starti+1); {The new entry is placed first}
end
else
starti:=i+1;
end;
end;
if First then
begin
Insert(CurrPath,List,LastAdd);
inc(LastAdd,Length(CurrPath));
end
else
if not Found then
List:=List+CurrPath
until (s='');
end;
function getpathfromlist(var list:string):string;
var
s : string;
i : longint;
begin
s:='';
while (list<>'') do
begin
i:=Pos(';',list);
If i=0 then
i:=255;
S:=Copy(list,1,i-1);
Delete (list,1,i);
if (S<>'') then
break;
end;
GetPathFromList:=s;
end;
function search(const f : string;path : string;var b : boolean) : string;
Var
singlepathstring : string;
i : longint;
begin
{$ifdef linux}
for i:=1 to length(path) do
if path[i]=':' then
path[i]:=';';
{$endif}
b:=false;
search:='';
repeat
i:=pos(';',path);
if i=0 then
i:=255;
singlepathstring:=FixPath(copy(path,1,i-1),false);
delete(path,1,i);
If FileExists (singlepathstring+f) then
begin
Search:=singlepathstring;
b:=true;
exit;
end;
until path='';
end;
Function GetFileTime ( Var F : File) : Longint;
Var
{$ifdef linux}
Info : Stat;
{$endif}
L : longint;
begin
{$ifdef linux}
FStat (F,Info);
L:=Info.Mtime;
{$else}
GetFTime(f,l);
{$endif}
GetFileTime:=L;
end;
Function GetNamedFileTime (Const F : String) : Longint;
var
L : Longint;
{$ifndef linux}
info : SearchRec;
{$else}
info : stat;
{$endif}
begin
l:=-1;
{$ifdef linux}
if FStat (F,Info) then
L:=info.mtime;
{$else}
{$ifdef delphi}
dmisc.FindFirst (F,archive+readonly+hidden,info);
{$else delphi}
FindFirst (F,archive+readonly+hidden,info);
{$endif delphi}
if DosError=0 then
l:=info.time;
{$ifdef Linux}
FindClose(info);
{$endif}
{$ifdef Win32}
FindClose(info);
{$endif}
{$endif}
GetNamedFileTime:=l;
end;
{Touch Assembler and object time to ppu time is there is a ppufilename}
procedure SynchronizeFileTime(const fn1,fn2:string);
var
f : file;
l : longint;
begin
Assign(f,fn1);
{$I-}
reset(f,1);
{$I+}
if ioresult=0 then
begin
getftime(f,l);
close(f);
assign(f,fn2);
{$I-}
reset(f,1);
{$I+}
if ioresult=0 then
begin
setftime(f,l);
close(f);
end;
end;
end;
function FindExe(bin:string;var found:boolean):string;
begin
bin:=FixFileName(bin)+source_os.exeext;
{$ifdef delphi}
FindExe:=Search(bin,'.;'+exepath+';'+dmisc.getenv('PATH'),found)+bin;
{$else delphi}
FindExe:=Search(bin,'.;'+exepath+';'+dos.getenv('PATH'),found)+bin;
{$endif delphi}
end;
procedure abstract;
begin
do_internalerror(255);
end;
Procedure Shell(const command:string);
{ This is already defined in the linux.ppu for linux, need for the *
expansion under linux }
{$ifdef linux}
begin
Linux.Shell(command);
end;
{$else}
var
comspec : string;
begin
comspec:=getenv('COMSPEC');
Exec(comspec,' /C '+command);
end;
{$endif}
{****************************************************************************
Init
****************************************************************************}
procedure get_exepath;
var
hs1 : namestr;
hs2 : extstr;
begin
{$ifdef delphi}
exepath:=dmisc.getenv('PPC_EXEC_PATH');
{$else delphi}
exepath:=dos.getenv('PPC_EXEC_PATH');
{$endif delphi}
if exepath='' then
fsplit(FixFileName(paramstr(0)),exepath,hs1,hs2);
{$ifdef linux}
if exepath='' then
fsearch(hs1,dos.getenv('PATH'));
{$endif}
exepath:=FixPath(exepath,false);
end;
procedure DoneGlobals;
begin
initdefines.done;
if assigned(DLLImageBase) then
StringDispose(DLLImageBase);
end;
procedure InitGlobals;
begin
{ set global switches }
do_build:=false;
do_make:=true;
{$ifdef tp}
use_big:=false;
{$endif tp}
{ Output }
OutputFile:='';
OutputExeDir:='';
OutputUnitDir:='';
{ Utils directory }
utilsdirectory:='';
{ Def file }
usewindowapi:=false;
description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
{ Init values }
initmodeswitches:=fpcmodeswitches;
initlocalswitches:=[cs_check_io];
initmoduleswitches:=[cs_extsyntax,cs_browser];
initglobalswitches:=[cs_check_unit_name,cs_link_static];
{$ifdef i386}
initoptprocessor:=Class386;
initpackenum:=4;
initpackrecords:=packrecord_2;
initoutputformat:=target_asm.id;
initasmmode:=asmmode_i386_att;
{$else not i386}
{$ifdef m68k}
initoptprocessor:=MC68000;
include(initmoduleswitches,cs_fp_emulation);
initpackenum:=4;
initpackrecords:=packrecord_2;
initoutputformat:=as_m68k_as;
initasmmode:=asmmode_m68k_mot;
{$endif m68k}
{$endif i386}
initdefines.init;
{ memory sizes, will be overriden by parameter or default for target
in options or init_parser }
stacksize:=0;
heapsize:=0;
maxheapsize:=0;
{ compile state }
in_args:=false;
must_be_valid:=true;
not_unit_proc:=true;
apptype:=at_cui;
end;
begin
get_exepath;
{$ifdef EXTDEBUG}
{$ifdef FPC}
EntryMemUsed:=system.HeapSize-MemAvail;
{$endif FPC}
{$endif}
end.
{
$Log$
Revision 1.27 1999-10-26 12:30:41 peter
* const parameter is now checked
* better and generic check if a node can be used for assigning
* export fixes
* procvar equal works now (it never had worked at least from 0.99.8)
* defcoll changed to linkedlist with pparaitem so it can easily be
walked both directions
Revision 1.26 1999/10/21 14:29:34 peter
* redesigned linker object
+ library support for linux (only procedures can be exported)
Revision 1.25 1999/09/10 18:48:02 florian
* some bug fixes (e.g. must_be_valid and procinfo.funcret_is_valid)
* most things for stored properties fixed
Revision 1.24 1999/09/08 16:05:31 peter
* pointer add/sub is now as expected and the same results as inc/dec
Revision 1.23 1999/09/07 15:11:00 pierre
* use do_internalerror insetead of runerror
Revision 1.22 1999/08/30 10:17:56 peter
* fixed crash in psub
* ansistringcompare fixed
* support for #$0b8
Revision 1.21 1999/08/27 10:45:00 pierre
options -Ca sets simply_ppu to true
Revision 1.20 1999/08/19 13:02:12 pierre
+ label faillabel added for _FAIL support
Revision 1.19 1999/08/16 15:35:21 pierre
* fix for DLL relocation problems
* external bss vars had wrong stabs for pecoff
+ -WB11000000 to specify default image base, allows to
load several DLLs with debugging info included
(relocatable DLL are stripped because the relocation
of the .Stab section is misplaced by ldw)
Revision 1.18 1999/08/11 17:26:32 peter
* tlinker object is now inherited for win32 and dos
* postprocessexecutable is now a method of tlinker
Revision 1.17 1999/08/10 12:51:14 pierre
* bind_win32_dll removed (Relocsection used instead)
* now relocsection is true by default ! (needs dlltool
for DLL generation)
Revision 1.16 1999/08/05 20:54:19 daniel
* Changes for new symtable.
Revision 1.15 1999/08/03 17:09:35 florian
* the alpha compiler can be compiled now
Revision 1.14 1999/07/23 16:05:19 peter
* alignment is now saved in the symtable
* C alignment added for records
* PPU version increased to solve .12 <-> .13 probs
Revision 1.13 1999/07/18 10:19:52 florian
* made it compilable with Dlephi 4 again
+ fixed problem with large stack allocations on win32
Revision 1.12 1999/07/13 19:14:44 michael
+ Defaultreplacemens now more logical
Revision 1.11 1999/07/10 10:26:18 peter
* merged
Revision 1.8.2.2 1999/07/10 10:03:04 peter
* fixed initialization/finalization in fpc mode
* allow $TARGET also in search paths
Revision 1.8.2.1 1999/07/07 07:53:21 michael
+ Merged patches from florian
Revision 1.10 1999/07/06 21:48:16 florian
* a lot bug fixes:
- po_external isn't any longer necessary for procedure compatibility
- m_tp_procvar is in -Sd now available
- error messages of procedure variables improved
- return values with init./finalization fixed
- data types with init./finalization aren't any longer allowed in variant
record
Revision 1.9 1999/07/03 00:29:48 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.8 1999/05/27 19:44:29 peter
* removed oldasm
* plabel -> pasmlabel
* -a switches to source writing automaticly
* assembler readers OOPed
* asmsymbol automaticly external
* jumptables and other label fixes for asm readers
Revision 1.7 1999/05/13 21:59:26 peter
* removed oldppu code
* warning if objpas is loaded from uses
* first things for new deref writing
Revision 1.6 1999/05/05 10:05:50 florian
* a delphi compiled compiler recompiles ppc
Revision 1.5 1999/05/04 21:44:43 florian
* changes to compile it with Delphi 4.0
Revision 1.4 1999/04/26 13:31:32 peter
* release storenumber,double_checksum
Revision 1.3 1999/04/21 14:12:55 peter
* default asm changed to att
Revision 1.2 1999/04/16 09:56:05 pierre
* unused local var commented
Revision 1.1 1999/04/08 09:14:46 michael
+ Re-added;
Revision 1.119 1999/04/07 14:15:53 pierre
* assigned test for FPC removed, problems with stack variables
Revision 1.118 1999/03/17 22:23:17 florian
* a FPC compiled compiler checks now also in debug mode in assigned
if a pointer points to the heap
* when a symtable is loaded, there is no need to check for duplicate
symbols. This leads to crashes because defowner isn't assigned
in this case
Revision 1.117 1999/03/04 13:55:42 pierre
* some m68k fixes (still not compilable !)
* new(tobj) does not give warning if tobj has no VMT !
Revision 1.116 1999/03/02 18:20:09 peter
* fixed compareansistring which gave always -1 or 1 and never 0 :)
Revision 1.115 1999/03/01 15:43:47 peter
* synchronize also the objfile for ag386bin
Revision 1.114 1999/02/25 21:02:36 peter
* ag386bin updates
+ coff writer
Revision 1.113 1999/02/22 13:06:50 pierre
+ -b and -bl options work !
+ cs_local_browser ($L+) is disabled if cs_browser ($Y+)
is not enabled when quitting global section
* local vars and procedures are not yet stored into PPU
Revision 1.111 1999/02/11 09:46:22 pierre
* fix for normal method calls inside static methods :
WARNING there were both parser and codegen errors !!
added static_call boolean to calln tree
Revision 1.110 1999/01/27 13:05:42 pierre
* give include file name on error
Revision 1.109 1999/01/22 16:56:50 pierre
* findclose problem fixed
Revision 1.108 1999/01/22 10:08:19 daniel
* Findclose is removed for go32v1 and go32v2 platforms, because this is
TP incompatible. It is now only called for Linux and Win32.
Revision 1.107 1999/01/12 14:25:27 peter
+ BrowserLog for browser.log generation
+ BrowserCol for browser info in TCollections
* released all other UseBrowser
Revision 1.106 1999/01/05 08:19:57 florian
* mainly problem with invalid case ranges fixed (reported by Jonas)
Revision 1.105 1998/12/28 23:26:16 peter
+ resource file handling ($R directive) for Win32
Revision 1.104 1998/12/23 22:49:42 peter
* forgot one conflict :(
Revision 1.103 1998/12/23 22:48:41 peter
* fixed findclose problem
Revision 1.102 1998/12/23 14:26:30 jonas
* patch from Peter: remove FindClose call in FileExists (caused error under Dos
when opening the ppc386.cfg file)
Revision 1.101 1998/12/23 14:02:00 peter
* daniels patches against the latest versions
Revision 1.99 1998/12/19 00:23:47 florian
* ansistring memory leaks fixed
Revision 1.98 1998/12/15 10:23:24 peter
+ -iSO, -iSP, -iTO, -iTP
Revision 1.97 1998/12/11 00:03:17 peter
+ globtype,tokens,version unit splitted from globals
Revision 1.96 1998/12/08 10:18:06 peter
+ -gh for heaptrc unit
Revision 1.95 1998/12/03 10:17:30 peter
* target_os.use_bound_instruction boolean
Revision 1.94 1998/11/30 13:26:22 pierre
* the code for ordering the exported procs/vars was buggy
+ added -WB to force binding (Ozerski way of creating DLL)
this is off by default as direct writing of .edata section seems
OK
Revision 1.93 1998/11/30 09:43:10 pierre
* some range check bugs fixed (still not working !)
+ added DLL writing support for win32 (also accepts variables)
+ TempAnsi for code that could be used for Temporary ansi strings
handling
Revision 1.92 1998/11/27 14:50:37 peter
+ open strings, $P switch support
Revision 1.91 1998/11/26 21:33:08 peter
* rangecheck updates
Revision 1.90 1998/11/24 17:03:23 peter
* removed obsolete version.inc
Revision 1.89 1998/11/16 15:41:41 peter
* tp7 didn't like my ifopt H+ :(
Revision 1.88 1998/11/16 10:17:07 peter
* fixed for H+ compilation
Revision 1.87 1998/11/15 16:32:36 florian
* some stuff of Pavel implement (win32 dll creation)
* bug with ansistring function results fixed
Revision 1.86 1998/11/05 12:02:43 peter
* released useansistring
* removed -Sv, its now available in fpc modes
Revision 1.85 1998/10/26 22:23:30 peter
+ fixpath() has an extra option to allow a ./ as path
Revision 1.84 1998/10/25 23:30:15 peter
* valint fix for tp7 to overcome overflow
Revision 1.83 1998/10/22 17:54:02 florian
+ switch $APPTYPE for win32 added
Revision 1.82 1998/10/22 11:56:44 pierre
* FixPath handling of c: corrected
Revision 1.81 1998/10/19 15:41:00 peter
* better splitname to support glib-1.1.dll alike names
Revision 1.80 1998/10/16 13:37:17 florian
+ switch -FD added to specify the path for utilities
Revision 1.79 1998/10/16 08:51:46 peter
+ target_os.stackalignment
+ stack can be aligned at 2 or 4 byte boundaries
Revision 1.78 1998/10/14 13:38:21 peter
* fixed path with staticlib/objects in ppufiles
Revision 1.77 1998/10/13 14:01:09 peter
* fixed -al
Revision 1.76 1998/10/13 13:10:15 peter
* new style for m68k/i386 infos and enums
Revision 1.75 1998/10/13 08:19:32 pierre
+ source_os is now set correctly for cross-processor compilers
(tos contains all target_infos and
we use CPU86 and CPU68 conditionals to
get the source operating system
this only works if you do not undefine
the source target !!)
* several cg68k memory leaks fixed
+ started to change the code so that it should be possible to have
a complete compiler (both for m68k and i386 !!)
Revision 1.74 1998/10/12 10:28:29 florian
+ auto dereferencing of pointers to structured types in delphi mode
Revision 1.73 1998/10/12 09:49:56 florian
+ support of <procedure var type>:=<pointer> in delphi mode added
Revision 1.72 1998/10/06 17:16:48 pierre
* some memory leaks fixed (thanks to Peter for heaptrc !)
Revision 1.71 1998/09/30 19:53:54 michael
+ Upgraded to version 0.99.9
Revision 1.70 1998/09/29 15:23:03 peter
* remove also the end files for smartlinking
Revision 1.69 1998/09/26 17:45:28 peter
+ idtoken and only one token table
Revision 1.68 1998/09/24 23:49:04 peter
+ aktmodeswitches
Revision 1.67 1998/09/22 17:13:46 pierre
+ browsing updated and developed
records and objects fields are also stored
Revision 1.66 1998/09/22 15:40:54 peter
* some extra ifdef GDB
Revision 1.65 1998/09/18 16:03:38 florian
* some changes to compile with Delphi
Revision 1.64 1998/09/10 15:25:29 daniel
+ Added maxheapsize.
* Corrected semi-bug in calling the assembler and the linker
Revision 1.63 1998/09/09 18:17:13 florian
* version number changed to 0.99.8
Revision 1.62 1998/09/07 17:36:59 florian
* first fixes for published properties
Revision 1.61 1998/09/03 11:21:52 peter
* -al sets cs_asm_source
Revision 1.60 1998/09/01 12:53:20 peter
+ aktpackenum
Revision 1.59 1998/09/01 07:54:18 pierre
* UseBrowser a little updated (might still be buggy !!)
* bug in psub.pas in function specifier removed
* stdcall allowed in interface and in implementation
(FPC will not yet complain if it is missing in either part
because stdcall is only a dummy !!)
Revision 1.58 1998/08/31 12:26:25 peter
* m68k and palmos updates from surebugfixes
Revision 1.57 1998/08/29 13:51:09 peter
* moved get_exepath to globals
+ date_string const with the current date for 0.99.7+
Revision 1.56 1998/08/26 15:35:31 peter
* fixed scannerfiles for macros
+ $I %<environment>%
Revision 1.55 1998/08/25 12:42:35 pierre
* CDECL changed to CVAR for variables
specifications are read in structures also
+ started adding GPC compatibility mode ( option -Sp)
* names changed to lowercase
Revision 1.54 1998/08/19 18:04:53 peter
* fixed current_module^.in_implementation flag
Revision 1.53 1998/08/19 16:07:45 jonas
* changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
Revision 1.52 1998/08/19 10:06:13 peter
* fixed filenames and removedir which supports slash at the end
Revision 1.51 1998/08/17 09:17:46 peter
* static/shared linking updates
Revision 1.50 1998/08/14 21:56:33 peter
* setting the outputfile using -o works now to create static libs
Revision 1.49 1998/08/13 10:57:31 peter
* constant sets are now written correctly to the ppufile
Revision 1.48 1998/08/11 15:31:37 peter
* write extended to ppu file
* new version 0.99.7
Revision 1.47 1998/08/10 14:49:59 peter
+ localswitches, moduleswitches, globalswitches splitting
Revision 1.46 1998/08/10 10:18:25 peter
+ Compiler,Comphook unit which are the new interface units to the
compiler
Revision 1.45 1998/07/24 22:16:56 florian
* internal error 10 together with array access fixed. I hope
that's the final fix.
Revision 1.44 1998/07/18 17:11:08 florian
+ ansi string constants fixed
+ switch $H partial implemented
Revision 1.43 1998/07/14 21:46:42 peter
* updated messages file
Revision 1.42 1998/07/08 14:28:35 daniel
* Fixed small TP incompatibility: Fsplit requires use of dirstr, namestr and
extstr
Revision 1.41 1998/07/07 11:19:56 peter
+ NEWINPUT for a better inputfile and scanner object
Revision 1.40 1998/06/25 08:48:13 florian
* first version of rtti support
Revision 1.39 1998/06/17 14:10:12 peter
* small os2 fixes
* fixed interdependent units with newppu (remake3 under linux works now)
Revision 1.38 1998/06/16 08:56:21 peter
+ targetcpu
* cleaner pmodules for newppu
Revision 1.37 1998/06/13 00:10:06 peter
* working browser and newppu
* some small fixes against crashes which occured in bp7 (but not in
fpc?!)
Revision 1.36 1998/06/12 16:15:31 pierre
* external name 'C_var';
export name 'intern_C_var';
cdecl;
cdecl;external;
are now supported only with -Sv switch
Revision 1.34 1998/06/04 23:51:39 peter
* m68k compiles
+ .def file creation moved to gendef.pas so it could also be used
for win32
Revision 1.33 1998/06/03 22:48:54 peter
+ wordbool,longbool
* rename bis,von -> high,low
* moved some systemunit loading/creating to psystem.pas
Revision 1.32 1998/05/30 14:31:04 peter
+ $ASMMODE
Revision 1.31 1998/05/28 14:40:24 peter
* fixes for newppu, remake3 works now with it
Revision 1.30 1998/05/27 19:45:03 peter
* symtable.pas splitted into includefiles
* symtable adapted for $ifdef NEWPPU
Revision 1.29 1998/05/25 17:11:39 pierre
* firstpasscount bug fixed
now all is already set correctly the first time
under EXTDEBUG try -gp to skip all other firstpasses
it works !!
* small bug fixes
- for smallsets with -dTESTSMALLSET
- some warnings removed (by correcting code !)
Revision 1.28 1998/05/23 01:21:07 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.27 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.26 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.25 1998/05/11 13:07:54 peter
+ $ifdef NEWPPU 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.24 1998/05/08 09:21:20 michael
* Added missing -Fl message to messages file.
* Corrected mangling of file names when doing Linklib
* -Fl now actually WORKS.
* Librarysearchpath is now a field in linker object.
Revision 1.23 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.22 1998/05/06 08:38:39 pierre
* better position info with UseTokenInfo
UseTokenInfo greatly simplified
+ added check for changed tree after first time firstpass
(if we could remove all the cases were it happen
we could skip all firstpass if firstpasscount > 1)
Only with ExtDebug
Revision 1.21 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.20 1998/05/01 07:43:53 florian
+ basics for rtti implemented
+ switch $m (generate rtti for published sections)
Revision 1.19 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.18 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.17 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.16 1998/04/27 15:45:20 peter
+ -Xl for smartlink
+ target_info.arext = .a
Revision 1.15 1998/04/22 21:06:50 florian
* last fixes before the release:
- veryyyy slow firstcall fixed
Revision 1.14 1998/04/21 13:48:09 michael
+ Updated patch number
Revision 1.13 1998/04/21 10:16:47 peter
* patches from strasbourg
* objects is not used anymore in the fpc compiled version
Revision 1.12 1998/04/09 14:28:06 jonas
+ basic k6 and 6x86 optimizing support (-O7 and -O8)
Revision 1.11 1998/04/08 16:58:02 pierre
* several bugfixes
ADD ADC and AND are also sign extended
nasm output OK (program still crashes at end
and creates wrong assembler files !!)
procsym types sym in tdef removed !!
Revision 1.10 1998/04/08 11:34:22 peter
* nasm works (linux only tested)
Revision 1.9 1998/04/07 21:37:30 peter
* fixed fixpath to also change / and \ slashes and better addpathtolist
Revision 1.8 1998/04/07 13:19:44 pierre
* bugfixes for reset_gdb_info
in MEM parsing for go32v2
better external symbol creation
support for rhgdb.exe (lowercase file names)
Revision 1.7 1998/04/06 16:19:46 peter
* fixed the -Up.. bug
}
Reference in New Issue View Git Blame Copy Permalink