paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-12 18:29:36 +02:00
Code Issues Packages Projects Releases Wiki Activity
795da2dce9
fpc/rtl/linux/syslinux.pp
root d1a1f501c8 Initial revision
1998-03-25 11:18:12 +00:00

743 lines
17 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by Michael Van Canneyt,
member of the Free Pascal development team.
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 want to link to the C library, set the conditional crtlib }
{ $define crtlib}
{ If you use an aout system, set the conditional AOUT}
{ $Define AOUT}
Unit SysLinux;
{$I os.inc}
Interface
{$I systemh.inc}
{$I heaph.inc}
const
UnusedHandle=$ffff;
StdInputHandle=0;
StdOutputHandle=1;
StdErrorHandle=2;
var argc : longint;
argv : ppchar;
envp : ppchar;
Implementation
{$I system.inc}
Type
PLongint = ^Longint;
{$ifdef crtlib}
Procedure _rtl_exit(l: longint); [ C ];
Function _rtl_paramcount: longint; [ C ];
Procedure _rtl_paramstr(st: pchar; l: longint); [ C ];
Function _rtl_open(f: pchar; flags: longint): longint; [ C ];
Procedure _rtl_close(h: longint); [ C ];
Procedure _rtl_write(h: longint; addr: longInt; len : longint); [ C ];
Procedure _rtl_erase(p: pchar); [ C ];
Procedure _rtl_rename(p1: pchar; p2 : pchar); [ C ];
Function _rtl_read(h: longInt; addr: longInt; len : longint) : longint; [ C ];
Function _rtl_filepos(Handle: longint): longint; [ C ];
Procedure _rtl_seek(Handle: longint; pos:longint); [ C ];
Function _rtl_filesize(Handle:longint): longInt; [ C ];
Procedure _rtl_rmdir(buffer: pchar); [ C ];
Procedure _rtl_mkdir(buffer: pchar); [ C ];
Procedure _rtl_chdir(buffer: pchar); [ C ];
{$else}
{ 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 syscalls.inc }
{$endif}
{*****************************************************************************
Misc. System Dependent Functions
*****************************************************************************}
Procedure Halt(ErrNum: Byte);
Begin
ExitCode:=Errnum;
ErrorAddr:=nil;
Do_Exit;
{$ifdef i386}
asm
jmp _haltproc
end;
{$else}
{$endif}
End;
Function ParamCount: Longint;
Begin
{$ifdef crtlib}
ParamCount := _rtl_paramcount;
{$else}
Paramcount := argc-1
{$endif}
End;
Function ParamStr(l: Longint): String;
Var
b : Array[0..255] of Char;
{$ifndef crtlib}
i : longint;
pp : ppchar;
{$endif}
Begin
{$ifdef crtlib}
_rtl_paramstr(@b, l);
{$else}
if l>argc then
begin
paramstr:='';
exit
end;
pp:=argv;
i:=0;
while (i<l) and (pp^<>nil) do
begin
pp:=pp+4;
inc(i);
end;
if pp^<>nil then
move (pp^^,b[0],255)
else
b[0]:=#0;
{$endif}
ParamStr:=StrPas(b);
End;
Procedure Randomize;
Begin
{$ifdef crtlib}
_rtl_gettime(longint(@randseed));
{$else}
randseed:=sys_time;
{$endif}
End;
{*****************************************************************************
Heap Management
*****************************************************************************}
{ ___brk_addr is defined and allocated in prt1.S. }
Function Get_Brk_addr : longint;
begin
{$ifdef i386}
asm
movl ___brk_addr,%eax
leave
ret
end ['EAX'];
{$else}
{$endif}
end;
Procedure Set_brk_addr (NewAddr : longint);
begin
{$ifdef i386}
asm
movl 8(%ebp),%eax
movl %eax,___brk_addr
end ['EAX'];
{$else}
{$endif}
end;
Function brk(Location : longint) : Longint;
{ set end of data segment to location }
var t : syscallregs;
dummy : longint;
begin
t.reg2:=Location;
dummy:=syscall (syscall_nr_brk,t);
{$ifdef debug}
writeln ('Brk syscall returned : ',dummy);
writeln ('Errno = ',errno);
{$endif}
set_brk_addr(dummy);
brk:=dummy;
end;
Function init_brk : longint;
begin
if Get_Brk_addr=0 then
begin
Set_brk_addr(brk(0));
if Get_brk_addr=0 then
exit(-1);
end;
init_brk:=0;
end;
Function sbrk(size : longint) : Longint;
var
Temp : longint;
begin
if init_brk=0 then
begin
Temp:=Get_Brk_Addr+size;
if brk(temp)=-1 then
exit(-1);
if Get_brk_addr=temp then
exit(temp-size);
end;
exit(-1);
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;
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 : Inoutres:=150;
Sys_EEXIST,
Sys_EACCES : Inoutres:=5;
Sys_ETXTBSY : Inoutres:=162;
end;
end;
Procedure Do_Close(Handle:Longint);
Begin
{$ifdef crtlib}
_rtl_close(Handle);
{$else}
sys_close(Handle);
{$endif}
End;
Procedure Do_Erase(p:pchar);
Begin
{$ifdef crtlib}
_rtl_erase(p);
{$else}
sys_unlink(p);
Errno2Inoutres;
{$endif}
End;
Procedure Do_Rename(p1,p2:pchar);
Begin
{$ifdef crtlib}
_rtl_rename(p1,p2);
{$else }
sys_rename(p1,p2);
Errno2Inoutres;
{$endif}
End;
Function Do_Write(Handle,Addr,Len:Longint):longint;
Begin
{$ifdef crtlib}
_rtl_write(Handle,addr,len);
Do_Write:=Len;
{$else}
Do_Write:=sys_write(Handle,pchar(addr),len);
Errno2Inoutres;
{$endif}
if Do_Write<0 then
Do_Write:=0;
End;
Function Do_Read(Handle,Addr,Len:Longint):Longint;
Begin
{$ifdef crtlib}
Do_Read:=_rtl_read(Handle,addr,len);
{$else}
Do_Read:=sys_read(Handle,pchar(addr),len);
Errno2Inoutres;
{$endif}
if Do_Read<0 then
Do_Read:=0;
End;
Function Do_FilePos(Handle: Longint): Longint;
Begin
{$ifdef crtlib}
Do_FilePos:=_rtl_filepos(Handle);
{$else}
Do_FilePos:=sys_lseek(Handle, 0, Seek_Cur);
Errno2Inoutres;
{$endif}
End;
Procedure Do_Seek(Handle,Pos:Longint);
Begin
{$ifdef crtlib}
_rtl_seek(Handle, Pos);
{$else}
sys_lseek(Handle, pos, Seek_set);
{$endif}
End;
Function Do_SeekEnd(Handle:Longint): Longint;
begin
{$ifdef crtlib}
Do_SeekEnd:=_rtl_filesize(Handle);
{$else}
Do_SeekEnd:=sys_lseek(Handle,0,Seek_End);
{$endif}
end;
Function Do_FileSize(Handle:Longint): Longint;
{$ifndef crtlib}
var
regs : Syscallregs;
Info : Stat;
{$endif}
Begin
{$ifdef crtlib}
Do_FileSize:=_rtl_filesize(Handle);
{$else}
regs.reg2:=Handle;
regs.reg3:=longint(@Info);
if SysCall(SysCall_nr_fstat,regs)=0 then
Do_FileSize:=Info.Size
else
Do_FileSize:=-1;
Errno2Inoutres;
{$endif}
End;
Procedure Do_Truncate(Handle,Pos:longint);
{$ifndef crtlib}
var
sr : syscallregs;
{$endif}
begin
{$ifndef crtlib}
sr.reg2:=Handle;
sr.reg3:=Pos;
syscall(syscall_nr_ftruncate,sr);
Errno2Inoutres;
{$endif}
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 $10) the file will be append
when (flags and $100) the file will be truncate/rewritten
when (flags and $1000) there is no check for close (needed for textfiles)
}
var
{$ifndef crtlib}
oflags : longint;
{$endif}
Begin
{ close first if opened }
if ((flags and $1000)=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 $100)=$100 then
oflags:=oflags or (Open_CREAT or Open_TRUNC)
else
if (flags and $10)=$10 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;
fmoutput,
fmappend : begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
{$ifdef crtlib}
FileRec(f).Handle:=_rtl_open(p, oflags);
if FileRec(f).Handle<0 then
InOutRes:=2
else
InOutRes:=0;
{$else}
FileRec(f).Handle:=sys_open(p,oflags,438);
Errno2Inoutres;
{$endif}
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);
Var
Buffer: Array[0..255] of Char;
Begin
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
{$ifdef crtlib}
_rtl_mkdir(@buffer);
{$else}
sys_mkdir(@buffer, 511);
Errno2Inoutres;
{$endif}
End;
Procedure RmDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Begin
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
{$ifdef crtlib}
_rtl_rmdir(@buffer);
{$else}
sys_rmdir(@buffer);
Errno2Inoutres;
{$endif}
End;
Procedure ChDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Begin
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
{$ifdef crtlib}
_rtl_chdir(@buffer);
{$else}
sys_chdir(@buffer);
Errno2Inoutres;
{$endif}
End;
procedure getdir(drivenr : byte;var dir : string);
{$ifndef crtlib}
var
thisdir : stat;
rootino,
thisino,
dotdotino : longint;
rootdev,
thisdev,
dotdotdev : word;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
mountpoint : boolean;
predot : string[255];
procedure dodispose (p : pdir);
begin
dispose (p^.buf);
dispose (p)
end;
{$endif}
begin
drivenr:=0;
dir:='';
{$ifndef crtlib}
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);
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;
if sys_stat (@(dummy[1]),thisdir)<0 then
d:=nil;
end;
until (d=nil) or ((thisdir.dev=thisdev) and (thisdir.ino=thisino) );
if (closedir (dirstream)<0) or (d=nil) then
begin
dodispose (dirstream);
exit;
end;
{ At this point, d.name contains the name of the current dir}
thedir:='/'+strpas(@(d^.name[0]))+thedir;
thisdev:=dotdotdev;
thisino:=dotdotino;
predot:=predot+'../';
{ We don't want to clutter op the heap with DIR records... }
dodispose (dirstream);
end;
{ Now rootino=thisino and rootdev=thisdev so we've reached / }
dir:=thedir
{$endif}
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
Procedure SegFaultHandler (Sig : longint);
begin
if sig=11 then
RunError (216);
end;
Procedure InstallSegFaultHandler;
var
sr : syscallregs;
begin
sr.reg2:=11;
sr.reg3:=longint(@SegFaultHandler);
syscall(syscall_nr_signal,sr);
end;
procedure OpenStdIO(var f:text;mode:word;const std:string;hdl:longint);
begin
Assign(f,std);
TextRec(f).Handle:=hdl;
TextRec(f).Mode:=mode;
TextRec(f).InOutFunc:=@FileInOutFunc;
TextRec(f).FlushFunc:=@FileInOutFunc;
TextRec(f).Closefunc:=@fileclosefunc;
end;
Begin
{ Initialize ExitProc }
ExitProc:=Nil;
{ Set up segfault Handler }
InstallSegFaultHandler;
{ Setup heap }
InitHeap;
{ Setup stdin, stdout and stderr }
OpenStdIO(Input,fmInput,'stdin',StdInputHandle);
OpenStdIO(Output,fmOutput,'stdout',StdOutputHandle);
OpenStdIO(StdErr,fmOutput,'stderr',StdErrorHandle);
{ Reset IO Error }
InOutRes:=0;
End.
{
$Log$
Revision 1.1 1998-03-25 11:18:43 root
Initial revision
Revision 1.15 1998/03/11 23:07:42 peter
* exit call moved to prt1/gprt1, halt() jmps to it
Revision 1.14 1998/02/08 21:52:54 peter
* Fixed a wrong result type by using Unusedhandle
Revision 1.13 1998/02/03 14:00:42 peter
* Faster getdir() and fixed memory leak in it
Revision 1.12 1998/01/27 17:48:30 peter
* faster FileSize() by using FStat() instead of LSeeks
Revision 1.11 1998/01/26 12:01:09 michael
+ Added log at the end
revision 1.10
date: 1998/01/25 21:53:33; author: peter; state: Exp; lines: +21 -15
+ Universal Handles support for StdIn/StdOut/StdErr
* Updated layout of sysamiga.pas
----------------------------
revision 1.9
date: 1998/01/11 02:47:33; author: michael; state: Exp; lines: +287 -429
* Changed files to use the new filestructure in /inc directory.
(By Peter Vreman)
----------------------------
revision 1.8
date: 1998/01/07 00:05:03; author: michael; state: Exp; lines: +17 -2
+ Final adjustments for a uniform file handling interface.
(From Peter Vreman)
----------------------------
revision 1.7
date: 1998/01/06 00:29:34; author: michael; state: Exp; lines: +260 -272
Implemented a system independent sequence of reset/rewrite/append fileopenfunc etc system \n (from Peter Vreman)
----------------------------
revision 1.6
date: 1998/01/05 16:51:22; author: michael; state: Exp; lines: +2 -28
+ Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
----------------------------
revision 1.5
date: 1998/01/05 13:42:28; author: michael; state: Exp; lines: +85 -72
* Changes to implement a more uniform file opening scheme (by Peter Vreman)
Minor adjustments (unneeded vars etc.)
----------------------------
revision 1.4
date: 1998/01/01 16:53:02; author: michael; state: Exp; lines: +9 -1
* Bug fixes in Blockread/Write and Chdir, they now return sensible error
numbers.
----------------------------
revision 1.3
date: 1997/12/23 16:30:14; author: michael; state: Exp; lines: +78 -74
* more efficient opening of stdin, stdout and stderr (from Peter Vreman)
+ Added correct IOresult return value for open function. (from Peter Vreman)
----------------------------
revision 1.2
date: 1997/12/01 12:31:18; author: michael; state: Exp; lines: +12 -19
+ Added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:55; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:55; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}
Reference in New Issue View Git Blame Copy Permalink