mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 20:09:25 +02:00
* no longer necessary
This commit is contained in:
marco
parent
359a077da1
commit
09bf7e5016
@ -1,865 +0,0 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2000 by Michael Van Canneyt,
|
||||
member of the Free Pascal development team.
|
||||
|
||||
This is the core of the system unit *nix systems (now FreeBSD
|
||||
and Unix).
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ These things are set in the makefile, }
|
||||
{ But you can override them here.}
|
||||
|
||||
{ If you use an aout system, set the conditional AOUT}
|
||||
{ $Define AOUT}
|
||||
|
||||
{$I system.inc}
|
||||
|
||||
{ used in syscall to report errors.}
|
||||
var
|
||||
Errno : longint;
|
||||
|
||||
{ Include constant and type definitions }
|
||||
{$i errno.inc } { Error numbers }
|
||||
{$i sysnr.inc } { System call numbers }
|
||||
{$i sysconst.inc } { Miscellaneous constants }
|
||||
{$i systypes.inc } { Types needed for system calls }
|
||||
|
||||
{ Read actual system call definitions. }
|
||||
{$i signal.inc}
|
||||
{$i syscalls.inc }
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Misc. System Dependent Functions
|
||||
*****************************************************************************}
|
||||
|
||||
procedure prthaltproc;external name '_haltproc';
|
||||
|
||||
Procedure System_exit;
|
||||
Begin
|
||||
prthaltproc;
|
||||
End;
|
||||
|
||||
|
||||
Function ParamCount: Longint;
|
||||
Begin
|
||||
Paramcount:=argc-1;
|
||||
End;
|
||||
|
||||
|
||||
Function ParamStr(l: Longint): String;
|
||||
var
|
||||
link,
|
||||
hs : string;
|
||||
i : longint;
|
||||
begin
|
||||
if l=0 then
|
||||
begin
|
||||
str(sys_getpid,hs);
|
||||
{$ifdef FreeBSD}
|
||||
hs:='/proc/'+hs+'/file'#0;
|
||||
{$else}
|
||||
hs:='/proc/'+hs+'/exe'#0;
|
||||
{$endif}
|
||||
i:=Sys_readlink(@hs[1],@link[1],high(link));
|
||||
{ it must also be an absolute filename, linux 2.0 points to a memory
|
||||
location so this will skip that }
|
||||
if (i>0) and (link[1]='/') then
|
||||
begin
|
||||
link[0]:=chr(i);
|
||||
paramstr:=link;
|
||||
end
|
||||
else
|
||||
paramstr:=strpas(argv[0]);
|
||||
end
|
||||
else
|
||||
if (l>0) and (l<argc) then
|
||||
paramstr:=strpas(argv[l])
|
||||
else
|
||||
paramstr:='';
|
||||
end;
|
||||
|
||||
|
||||
Procedure Randomize;
|
||||
Begin
|
||||
randseed:=sys_time;
|
||||
End;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Heap Management
|
||||
*****************************************************************************}
|
||||
|
||||
var
|
||||
_HEAP : pointer;external name 'HEAP';
|
||||
_HEAPSIZE : longint;external name 'HEAPSIZE';
|
||||
|
||||
function getheapstart:pointer;assembler;
|
||||
{$undef fpc_getheapstart_ok}
|
||||
{$ifdef cpui386}
|
||||
{$define fpc_getheapstart_ok}
|
||||
asm
|
||||
leal _HEAP,%eax
|
||||
end ['EAX'];
|
||||
{$endif cpui386}
|
||||
{$ifdef cpum68k}
|
||||
{$define fpc_getheapstart_ok}
|
||||
asm
|
||||
lea.l _HEAP,a0
|
||||
move.l a0,d0
|
||||
end['A0','D0'];
|
||||
{$endif cpum68k}
|
||||
{$ifdef cpupowerpc}
|
||||
{$define fpc_getheapstart_ok}
|
||||
asm
|
||||
lis r3,HEAP@ha
|
||||
la r3,HEAP@l(r3)
|
||||
end['R3'];
|
||||
{$endif cpupowerpc}
|
||||
{$ifndef fpc_getheapstart_ok}
|
||||
asm
|
||||
end;
|
||||
{$error Getheapstart code is not implemented }
|
||||
{$endif not fpc_getheapstart_ok}
|
||||
|
||||
|
||||
function getheapsize:longint;assembler;
|
||||
{$undef fpc_getheapsize_ok}
|
||||
{$ifdef cpui386}
|
||||
{$define fpc_getheapsize_ok}
|
||||
asm
|
||||
movl _HEAPSIZE,%eax
|
||||
end ['EAX'];
|
||||
{$endif cpui386}
|
||||
{$ifdef cpum68k}
|
||||
{$define fpc_getheapsize_ok}
|
||||
asm
|
||||
move.l _HEAPSIZE,d0
|
||||
end ['D0'];
|
||||
{$endif cpum68k}
|
||||
{$ifdef cpupowerpc}
|
||||
{$define fpc_getheapsize_ok}
|
||||
asm
|
||||
lis r9,HEAPSIZE@ha
|
||||
lwz r3,HEAPSIZE@l(r9)
|
||||
end ['R0','R9'];
|
||||
{$endif cpupowerpc}
|
||||
{$ifndef fpc_getheapsize_ok}
|
||||
asm
|
||||
end;
|
||||
{$error Getheapsize code is not implemented }
|
||||
{$endif not fpc_getheapsize_ok}
|
||||
|
||||
|
||||
Function sbrk(size : longint) : pointer;
|
||||
var address:longint;
|
||||
begin
|
||||
address:=Sys_mmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0);
|
||||
if addres=-1 then inc(address) else errno := 0;
|
||||
sbrk:=pointer(address);
|
||||
end;
|
||||
|
||||
|
||||
{ include standard heap management }
|
||||
{$I heap.inc}
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Low Level File Routines
|
||||
*****************************************************************************}
|
||||
|
||||
{
|
||||
The lowlevel file functions should take care of setting the InOutRes to the
|
||||
correct value if an error has occured, else leave it untouched
|
||||
}
|
||||
|
||||
Procedure Errno2Inoutres;
|
||||
{
|
||||
Convert ErrNo error to the correct Inoutres value
|
||||
}
|
||||
|
||||
begin
|
||||
if ErrNo=0 then { Else it will go through all the cases }
|
||||
exit;
|
||||
If errno<0 then Errno:=-errno;
|
||||
case ErrNo of
|
||||
Sys_ENFILE,
|
||||
Sys_EMFILE : Inoutres:=4;
|
||||
Sys_ENOENT : Inoutres:=2;
|
||||
Sys_EBADF : Inoutres:=6;
|
||||
Sys_ENOMEM,
|
||||
Sys_EFAULT : Inoutres:=217;
|
||||
Sys_EINVAL : Inoutres:=218;
|
||||
Sys_EPIPE,
|
||||
Sys_EINTR,
|
||||
Sys_EIO,
|
||||
Sys_EAGAIN,
|
||||
Sys_ENOSPC : Inoutres:=101;
|
||||
Sys_ENAMETOOLONG,
|
||||
Sys_ELOOP,
|
||||
Sys_ENOTDIR : Inoutres:=3;
|
||||
Sys_EROFS,
|
||||
Sys_EEXIST,
|
||||
Sys_EISDIR,
|
||||
Sys_ENOTEMPTY,
|
||||
Sys_EACCES,
|
||||
Sys_ETXTBSY : Inoutres:=5;
|
||||
else
|
||||
InOutRes := Integer(Errno);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Procedure Do_Close(Handle:Longint);
|
||||
Begin
|
||||
sys_close(Handle);
|
||||
{Errno2Inoutres;}
|
||||
End;
|
||||
|
||||
|
||||
Procedure Do_Erase(p:pchar);
|
||||
{$ifdef BSD}
|
||||
var FileInfo : Stat;
|
||||
{$endif}
|
||||
|
||||
Begin
|
||||
{$ifdef BSD} {or POSIX}
|
||||
{ verify if the filename is actually a directory }
|
||||
{ if so return error and do nothing, as defined }
|
||||
{ by POSIX }
|
||||
if sys_stat(p,fileinfo)<0 then
|
||||
begin
|
||||
Errno2Inoutres;
|
||||
exit;
|
||||
end;
|
||||
{$ifdef BSD}
|
||||
if (fileinfo.mode and STAT_IFMT)=STAT_IFDIR then
|
||||
{$else}
|
||||
if s_ISDIR(fileinfo.st_mode) then
|
||||
{$endif}
|
||||
begin
|
||||
InOutRes := 2;
|
||||
exit;
|
||||
end;
|
||||
{$endif}
|
||||
sys_unlink(p);
|
||||
Errno2Inoutres;
|
||||
{$ifdef Linux}
|
||||
{ tp compatible result }
|
||||
if (Errno=Sys_EISDIR) then
|
||||
InOutRes:=2;
|
||||
{$endif}
|
||||
End;
|
||||
|
||||
|
||||
Procedure Do_Rename(p1,p2:pchar);
|
||||
Begin
|
||||
sys_rename(p1,p2);
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
Function Do_Write(Handle,Addr,Len:Longint):longint;
|
||||
Begin
|
||||
repeat
|
||||
Do_Write:=sys_write(Handle,pchar(addr),len);
|
||||
until ErrNo<>Sys_EINTR;
|
||||
Errno2Inoutres;
|
||||
if Do_Write<0 then
|
||||
Do_Write:=0;
|
||||
End;
|
||||
|
||||
|
||||
Function Do_Read(Handle,Addr,Len:Longint):Longint;
|
||||
Begin
|
||||
repeat
|
||||
Do_Read:=sys_read(Handle,pchar(addr),len);
|
||||
until ErrNo<>Sys_EINTR;
|
||||
Errno2Inoutres;
|
||||
if Do_Read<0 then
|
||||
Do_Read:=0;
|
||||
End;
|
||||
|
||||
|
||||
{Function Do_Write(Handle,Addr,Len:Longint):longint;
|
||||
var
|
||||
total,
|
||||
res : longint;
|
||||
Begin
|
||||
total:=0;
|
||||
repeat
|
||||
res:=sys_write(Handle,pchar(pchar(addr)+total),len-total);
|
||||
if res>0 then
|
||||
inc(total,res);
|
||||
until ErrNo<>Sys_EINTR;
|
||||
Errno2Inoutres;
|
||||
if res<0 then
|
||||
Do_Write:=0
|
||||
else
|
||||
Do_Write:=total;
|
||||
End;
|
||||
|
||||
|
||||
Function Do_Read(Handle,Addr,Len:Longint):Longint;
|
||||
var
|
||||
total,
|
||||
res : longint;
|
||||
Begin
|
||||
total:=0;
|
||||
repeat
|
||||
res:=sys_read(Handle,pchar(pchar(addr)+total),len-total);
|
||||
if res>0 then
|
||||
inc(total,res);
|
||||
until ErrNo<>Sys_EINTR;
|
||||
Errno2Inoutres;
|
||||
if res<0 then
|
||||
Do_Read:=0
|
||||
else
|
||||
Do_Read:=total;
|
||||
End;
|
||||
}
|
||||
|
||||
Function Do_FilePos(Handle: Longint): Longint;
|
||||
Begin
|
||||
Do_FilePos:=sys_lseek(Handle, 0, Seek_Cur);
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Procedure Do_Seek(Handle,Pos:Longint);
|
||||
Begin
|
||||
sys_lseek(Handle, pos, Seek_set);
|
||||
errno2inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Function Do_SeekEnd(Handle:Longint): Longint;
|
||||
begin
|
||||
Do_SeekEnd:=sys_lseek(Handle,0,Seek_End);
|
||||
errno2inoutres;
|
||||
end;
|
||||
|
||||
Function Do_FileSize(Handle:Longint): Longint;
|
||||
var
|
||||
Info : Stat;
|
||||
Begin
|
||||
if sys_fstat(handle,info)=0 then
|
||||
Do_FileSize:=Info.Size
|
||||
else
|
||||
Do_FileSize:=0;
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Procedure Do_Truncate(Handle,fPos:longint);
|
||||
begin
|
||||
sys_ftruncate(handle,fpos);
|
||||
Errno2Inoutres;
|
||||
end;
|
||||
|
||||
|
||||
Procedure Do_Open(var f;p:pchar;flags:longint);
|
||||
{
|
||||
FileRec and textrec have both Handle and mode as the first items so
|
||||
they could use the same routine for opening/creating.
|
||||
when (flags and $100) the file will be append
|
||||
when (flags and $1000) the file will be truncate/rewritten
|
||||
when (flags and $10000) there is no check for close (needed for textfiles)
|
||||
}
|
||||
var
|
||||
oflags : longint;
|
||||
|
||||
Begin
|
||||
{ close first if opened }
|
||||
if ((flags and $10000)=0) then
|
||||
begin
|
||||
case FileRec(f).mode of
|
||||
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
|
||||
fmclosed : ;
|
||||
else
|
||||
begin
|
||||
inoutres:=102; {not assigned}
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{ reset file Handle }
|
||||
FileRec(f).Handle:=UnusedHandle;
|
||||
|
||||
{ We do the conversion of filemodes here, concentrated on 1 place }
|
||||
case (flags and 3) of
|
||||
0 : begin
|
||||
oflags :=Open_RDONLY;
|
||||
FileRec(f).mode:=fminput;
|
||||
end;
|
||||
1 : begin
|
||||
oflags :=Open_WRONLY;
|
||||
FileRec(f).mode:=fmoutput;
|
||||
end;
|
||||
2 : begin
|
||||
oflags :=Open_RDWR;
|
||||
FileRec(f).mode:=fminout;
|
||||
end;
|
||||
end;
|
||||
if (flags and $1000)=$1000 then
|
||||
oflags:=oflags or (Open_CREAT or Open_TRUNC)
|
||||
else
|
||||
if (flags and $100)=$100 then
|
||||
oflags:=oflags or (Open_APPEND);
|
||||
|
||||
{ empty name is special }
|
||||
if p[0]=#0 then
|
||||
begin
|
||||
case FileRec(f).mode of
|
||||
fminput :
|
||||
FileRec(f).Handle:=StdInputHandle;
|
||||
fminout, { this is set by rewrite }
|
||||
fmoutput :
|
||||
FileRec(f).Handle:=StdOutputHandle;
|
||||
fmappend :
|
||||
begin
|
||||
FileRec(f).Handle:=StdOutputHandle;
|
||||
FileRec(f).mode:=fmoutput; {fool fmappend}
|
||||
end;
|
||||
end;
|
||||
exit;
|
||||
end;
|
||||
{ real open call }
|
||||
FileRec(f).Handle:=sys_open(p,oflags,438);
|
||||
if (ErrNo=Sys_EROFS) and ((OFlags and Open_RDWR)<>0) then
|
||||
begin
|
||||
Oflags:=Oflags and not(Open_RDWR);
|
||||
FileRec(f).Handle:=sys_open(p,oflags,438);
|
||||
end;
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Function Do_IsDevice(Handle:Longint):boolean;
|
||||
{
|
||||
Interface to Unix ioctl call.
|
||||
Performs various operations on the filedescriptor Handle.
|
||||
Ndx describes the operation to perform.
|
||||
Data points to data needed for the Ndx function. The structure of this
|
||||
data is function-dependent.
|
||||
}
|
||||
var
|
||||
Data : array[0..255] of byte; {Large enough for termios info}
|
||||
begin
|
||||
Do_IsDevice:=(sys_ioctl(handle,IOCTL_TCGETS,@data)<>-1);
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
UnTyped File Handling
|
||||
*****************************************************************************}
|
||||
|
||||
{$i file.inc}
|
||||
|
||||
{*****************************************************************************
|
||||
Typed File Handling
|
||||
*****************************************************************************}
|
||||
|
||||
{$i typefile.inc}
|
||||
|
||||
{*****************************************************************************
|
||||
Text File Handling
|
||||
*****************************************************************************}
|
||||
|
||||
{$DEFINE SHORT_LINEBREAK}
|
||||
{$DEFINE EXTENDED_EOF}
|
||||
|
||||
{$i text.inc}
|
||||
|
||||
{*****************************************************************************
|
||||
Directory Handling
|
||||
*****************************************************************************}
|
||||
|
||||
Procedure MkDir(Const s: String);[IOCheck];
|
||||
Var
|
||||
Buffer: Array[0..255] of Char;
|
||||
Begin
|
||||
If (s='') or (InOutRes <> 0) then
|
||||
exit;
|
||||
Move(s[1], Buffer, Length(s));
|
||||
Buffer[Length(s)] := #0;
|
||||
sys_mkdir(@buffer, 511);
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Procedure RmDir(Const s: String);[IOCheck];
|
||||
Var
|
||||
Buffer: Array[0..255] of Char;
|
||||
Begin
|
||||
if (s ='.') then
|
||||
InOutRes := 16;
|
||||
If (s='') or (InOutRes <> 0) then
|
||||
exit;
|
||||
Move(s[1], Buffer, Length(s));
|
||||
Buffer[Length(s)] := #0;
|
||||
sys_rmdir(@buffer);
|
||||
{$ifdef BSD}
|
||||
if (Errno=Sys_EINVAL) Then
|
||||
InOutRes:=5
|
||||
Else
|
||||
{$endif}
|
||||
Errno2Inoutres;
|
||||
End;
|
||||
|
||||
|
||||
Procedure ChDir(Const s: String);[IOCheck];
|
||||
Var
|
||||
Buffer: Array[0..255] of Char;
|
||||
Begin
|
||||
If (s='') or (InOutRes <> 0) then
|
||||
exit;
|
||||
Move(s[1], Buffer, Length(s));
|
||||
Buffer[Length(s)] := #0;
|
||||
sys_chdir(@buffer);
|
||||
Errno2Inoutres;
|
||||
{ file not exists is path not found under tp7 }
|
||||
if InOutRes=2 then
|
||||
InOutRes:=3;
|
||||
End;
|
||||
|
||||
|
||||
procedure GetDir (DriveNr: byte; var Dir: ShortString);
|
||||
var
|
||||
thisdir : stat;
|
||||
rootino,
|
||||
thisino,
|
||||
dotdotino : longint;
|
||||
rootdev,
|
||||
thisdev,
|
||||
dotdotdev : dev_t;
|
||||
thedir,dummy : string[255];
|
||||
dirstream : pdir;
|
||||
d : pdirent;
|
||||
mountpoint,validdir : boolean;
|
||||
predot : string[255];
|
||||
begin
|
||||
drivenr:=0;
|
||||
dir:='';
|
||||
thedir:='/'#0;
|
||||
if sys_stat(@thedir[1],thisdir)<0 then
|
||||
exit;
|
||||
rootino:=thisdir.ino;
|
||||
rootdev:=thisdir.dev;
|
||||
thedir:='.'#0;
|
||||
if sys_stat(@thedir[1],thisdir)<0 then
|
||||
exit;
|
||||
thisino:=thisdir.ino;
|
||||
thisdev:=thisdir.dev;
|
||||
{ Now we can uniquely identify the current and root dir }
|
||||
thedir:='';
|
||||
predot:='';
|
||||
while not ((thisino=rootino) and (thisdev=rootdev)) do
|
||||
begin
|
||||
{ Are we on a mount point ? }
|
||||
dummy:=predot+'..'#0;
|
||||
if sys_stat(@dummy[1],thisdir)<0 then
|
||||
exit;
|
||||
dotdotino:=thisdir.ino;
|
||||
dotdotdev:=thisdir.dev;
|
||||
mountpoint:=(thisdev<>dotdotdev);
|
||||
{ Now, Try to find the name of this dir in the previous one }
|
||||
dirstream:=opendir (@dummy[1]);
|
||||
if dirstream=nil then
|
||||
exit;
|
||||
repeat
|
||||
d:=sys_readdir (dirstream);
|
||||
validdir:=false;
|
||||
if (d<>nil) and
|
||||
(not ((d^.name[0]='.') and ((d^.name[1]=#0) or ((d^.name[1]='.')
|
||||
and (d^.name[2]=#0))))) and
|
||||
(mountpoint or (d^.ino=thisino)) then
|
||||
begin
|
||||
dummy:=predot+'../'+strpas(@(d^.name[0]))+#0;
|
||||
validdir:=not (sys_stat (@(dummy[1]),thisdir)<0);
|
||||
end
|
||||
else
|
||||
validdir:=false;
|
||||
until (d=nil) or
|
||||
((validdir) and (thisdir.dev=thisdev) and (thisdir.ino=thisino) );
|
||||
{ At this point, d.name contains the name of the current dir}
|
||||
if (d<>nil) then
|
||||
thedir:='/'+strpas(@(d^.name[0]))+thedir;
|
||||
{ closedir also makes d invalid }
|
||||
if (closedir(dirstream)<0) or (d=nil) then
|
||||
exit;
|
||||
thisdev:=dotdotdev;
|
||||
thisino:=dotdotino;
|
||||
predot:=predot+'../';
|
||||
end;
|
||||
{ Now rootino=thisino and rootdev=thisdev so we've reached / }
|
||||
dir:=thedir
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
{$ifdef BSD}
|
||||
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
|
||||
{$else}
|
||||
{$ifdef Solaris}
|
||||
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec;someptr:pointer); cdecl;
|
||||
{$else}
|
||||
procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl;
|
||||
{$endif}
|
||||
{$ENDIF}
|
||||
var
|
||||
|
||||
res,fpustate : word;
|
||||
begin
|
||||
res:=0;
|
||||
case sig of
|
||||
SIGFPE :
|
||||
begin
|
||||
{ this is not allways necessary but I don't know yet
|
||||
how to tell if it is or not PM }
|
||||
{$ifdef cpui386}
|
||||
fpustate:=0;
|
||||
res:=200;
|
||||
{$ifndef FreeBSD}
|
||||
if assigned(SigContext.fpstate) then
|
||||
fpuState:=SigContext.fpstate^.sw;
|
||||
{$else}
|
||||
fpustate:=SigContext.en_sw;
|
||||
{$ifdef SYSTEM_DEBUG}
|
||||
writeln('xx:',sigcontext.en_tw,' ',sigcontext.en_cw);
|
||||
{$endif SYSTEM_DEBUG}
|
||||
{$endif}
|
||||
{$ifdef SYSTEM_DEBUG}
|
||||
Writeln(stderr,'FpuState = ',FpuState);
|
||||
{$endif SYSTEM_DEBUG}
|
||||
if (FpuState and $7f) <> 0 then
|
||||
begin
|
||||
{ first check te more precise options }
|
||||
if (FpuState and FPU_DivisionByZero)<>0 then
|
||||
res:=200
|
||||
else if (FpuState and FPU_Overflow)<>0 then
|
||||
res:=205
|
||||
else if (FpuState and FPU_Underflow)<>0 then
|
||||
res:=206
|
||||
else if (FpuState and FPU_Denormal)<>0 then
|
||||
res:=216
|
||||
else if (FpuState and (FPU_StackOverflow or FPU_StackUnderflow))<>0 then
|
||||
res:=207
|
||||
else if (FpuState and FPU_Invalid)<>0 then
|
||||
res:=216
|
||||
else
|
||||
res:=207; {'Coprocessor Error'}
|
||||
end;
|
||||
{$endif cpui386}
|
||||
SysResetFPU;
|
||||
end;
|
||||
SIGILL,
|
||||
SIGBUS,
|
||||
SIGSEGV :
|
||||
res:=216;
|
||||
end;
|
||||
{ give runtime error at the position where the signal was raised }
|
||||
if res<>0 then
|
||||
begin
|
||||
{$ifdef cpui386}
|
||||
{$ifdef FreeBSD}
|
||||
HandleErrorAddrFrame(res,SigContext.sc_eip,SigContext.sc_ebp);
|
||||
{$else}
|
||||
HandleErrorAddrFrame(res,SigContext.eip,SigContext.ebp);
|
||||
{$endif}
|
||||
{$else}
|
||||
HandleError(res);
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Procedure InstallSignals;
|
||||
const
|
||||
{$Ifndef BSD}
|
||||
{$ifdef solaris}
|
||||
act: SigActionRec =(sa_flags:SA_SIGINFO;Handler:(sa:@signaltorunerror;sa_mask:0);
|
||||
{$else}
|
||||
act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_mask:0;sa_flags:0;
|
||||
Sa_restorer: NIL);
|
||||
{$endif}
|
||||
{$ELSE}
|
||||
act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_flags:SA_SIGINFO;
|
||||
sa_mask:0);
|
||||
{$endif}
|
||||
|
||||
oldact: PSigActionRec = Nil; {Probably not necessary anymore, now
|
||||
VAR is removed}
|
||||
begin
|
||||
SysResetFPU;
|
||||
SigAction(SIGFPE,@act,oldact);
|
||||
{$ifndef Solaris}
|
||||
SigAction(SIGSEGV,@act,oldact);
|
||||
SigAction(SIGBUS,@act,oldact);
|
||||
SigAction(SIGILL,@act,oldact);
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
|
||||
procedure SetupCmdLine;
|
||||
var
|
||||
bufsize,
|
||||
len,j,
|
||||
size,i : longint;
|
||||
found : boolean;
|
||||
buf : array[0..1026] of char;
|
||||
|
||||
procedure AddBuf;
|
||||
begin
|
||||
reallocmem(cmdline,size+bufsize);
|
||||
move(buf,cmdline[size],bufsize);
|
||||
inc(size,bufsize);
|
||||
bufsize:=0;
|
||||
end;
|
||||
|
||||
begin
|
||||
size:=0;
|
||||
bufsize:=0;
|
||||
i:=0;
|
||||
while (i<argc) do
|
||||
begin
|
||||
len:=strlen(argv[i]);
|
||||
if len>sizeof(buf)-2 then
|
||||
len:=sizeof(buf)-2;
|
||||
found:=false;
|
||||
for j:=1 to len do
|
||||
if argv[i][j]=' ' then
|
||||
begin
|
||||
found:=true;
|
||||
break;
|
||||
end;
|
||||
if bufsize+len>=sizeof(buf)-2 then
|
||||
AddBuf;
|
||||
if found then
|
||||
begin
|
||||
buf[bufsize]:='"';
|
||||
inc(bufsize);
|
||||
end;
|
||||
move(argv[i]^,buf[bufsize],len);
|
||||
inc(bufsize,len);
|
||||
if found then
|
||||
begin
|
||||
buf[bufsize]:='"';
|
||||
inc(bufsize);
|
||||
end;
|
||||
if i<argc then
|
||||
buf[bufsize]:=' '
|
||||
else
|
||||
buf[bufsize]:=#0;
|
||||
inc(bufsize);
|
||||
inc(i);
|
||||
end;
|
||||
AddBuf;
|
||||
end;
|
||||
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
IsConsole := TRUE;
|
||||
IsLibrary := FALSE;
|
||||
{ Setup stack checking variables }
|
||||
StackLength := InitialStkLen;
|
||||
StackBottom := Sptr - StackLength;
|
||||
{ Set up signals handlers }
|
||||
InstallSignals;
|
||||
{ Setup heap }
|
||||
InitHeap;
|
||||
SysInitExceptions;
|
||||
{ Arguments }
|
||||
SetupCmdLine;
|
||||
{ Setup stdin, stdout and stderr }
|
||||
SysInitStdIO;
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
{ Setup variant support }
|
||||
{$ifdef HASVARIANT}
|
||||
initvariantmanager;
|
||||
{$endif HASVARIANT}
|
||||
End.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.36 2003-10-17 20:45:58 olle
|
||||
* Changed mapping of Sys_ETXTBSY to 5
|
||||
* Changed m68k to cpum68k, i386 to cpui386
|
||||
|
||||
Revision 1.35 2003/10/13 21:24:04 hajny
|
||||
* sbrk error handling corrected
|
||||
|
||||
Revision 1.34 2003/09/27 11:52:36 peter
|
||||
* sbrk returns pointer
|
||||
|
||||
Revision 1.33 2003/09/03 14:09:37 florian
|
||||
* arm fixes to the common rtl code
|
||||
* some generic math code fixed
|
||||
* ...
|
||||
|
||||
Revision 1.32 2003/08/21 22:21:00 olle
|
||||
- removed parameter from fpc_iocheck
|
||||
|
||||
Revision 1.31 2002/10/14 19:39:17 peter
|
||||
* threads unit added for thread support
|
||||
|
||||
Revision 1.30 2002/10/13 09:20:56 peter
|
||||
* added initvariantmanager
|
||||
|
||||
Revision 1.29 2002/09/07 16:01:27 peter
|
||||
* old logs removed and tabs fixed
|
||||
|
||||
Revision 1.28 2002/09/02 19:46:37 florian
|
||||
* fixed line breaks
|
||||
|
||||
Revision 1.27 2002/08/31 21:29:57 florian
|
||||
* several PC related fixes
|
||||
|
||||
Revision 1.26 2002/08/13 18:11:08 florian
|
||||
* heap stuff for powerpc fixed
|
||||
|
||||
Revision 1.25 2002/08/03 20:05:13 florian
|
||||
+ ppc implementation of heap functions added
|
||||
|
||||
Revision 1.24 2002/07/29 21:28:17 florian
|
||||
* several fixes to get further with linux/ppc system unit compilation
|
||||
|
||||
Revision 1.23 2002/07/28 20:43:49 florian
|
||||
* several fixes for linux/powerpc
|
||||
* several fixes to MT
|
||||
|
||||
Revision 1.22 2002/05/31 13:37:24 marco
|
||||
* more Renamefest
|
||||
|
||||
Revision 1.21 2002/04/21 15:55:00 carl
|
||||
+ initialize some global variables
|
||||
|
||||
Revision 1.20 2002/04/12 17:43:28 carl
|
||||
+ generic stack checking
|
||||
|
||||
Revision 1.19 2002/03/11 19:10:33 peter
|
||||
* Regenerated with updated fpcmake
|
||||
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user