{ $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. 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; Interface {$ifdef m68k} { used for single computations } const BIAS4 = $7f-1; {$endif} {$ifdef BSD} {$define newsignal} {$endif} {$I systemh.inc} {$I heaph.inc} const UnusedHandle = -1; StdInputHandle = 0; StdOutputHandle = 1; StdErrorHandle = 2; var argc : longint; argv : ppchar; envp : ppchar; Implementation {$I system.inc} {$ifdef crtlib} Procedure _rtl_exit(l: longint); cdecl; Function _rtl_paramcount: longint; cdecl; Procedure _rtl_paramstr(st: pchar; l: longint); cdecl; Function _rtl_open(f: pchar; flags: longint): longint; cdecl; Procedure _rtl_close(h: longint); cdecl; Procedure _rtl_write(h: longint; addr: longInt; len : longint); cdecl; Procedure _rtl_erase(p: pchar); cdecl; Procedure _rtl_rename(p1: pchar; p2 : pchar); cdecl; Function _rtl_read(h: longInt; addr: longInt; len : longint) : longint; cdecl; Function _rtl_filepos(Handle: longint): longint; cdecl; Procedure _rtl_seek(Handle: longint; pos:longint); cdecl; Function _rtl_filesize(Handle:longint): longInt; cdecl; Procedure _rtl_rmdir(buffer: pchar); cdecl; Procedure _rtl_mkdir(buffer: pchar); cdecl; Procedure _rtl_chdir(buffer: pchar); cdecl; {$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 prthaltproc;external name '_haltproc'; procedure System_exit; begin {$ifdef i386} asm jmp prthaltproc end; {$else} asm jmp prthaltproc end; {$endif} 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); hs:='/proc/'+hs+'/exe'#0; i:=Sys_readlink(@hs[1],@link[1],high(link)); if i>0 then begin link[0]:=chr(i); paramstr:=link; end else paramstr:=strpas(argv[0]); end else if (l>0) and (l0 then Sbrk:=0; end; {$else} Function sbrk(size : longint) : Longint; type tmmapargs=packed record address : longint; size : longint; prot : longint; flags : longint; fd : longint; offset : longint; end; var t : syscallregs; mmapargs : tmmapargs; begin mmapargs.address:=0; mmapargs.size:=Size; mmapargs.prot:=3; mmapargs.flags:=$22; mmapargs.fd:=-1; mmapargs.offset:=0; t.reg2:=longint(@mmapargs); Sbrk:=syscall(syscall_nr_mmap,t); if ErrNo<>0 then Sbrk:=0; end; {$endif} { 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, 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; {$ifdef BSD} Function Do_FileSize(Handle:Longint): Longint; {$ifndef crtlib} var Info : Stat; {$endif} Begin {$ifdef crtlib} Do_FileSize:=_rtl_filesize(Handle); {$else} if do_SysCall(syscall_nr_fstat,handle,longint(@info))=0 then Do_FileSize:=Info.Size else Do_FileSize:=0; Errno2Inoutres; {$endif} End; {$ELSE} 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:=0; Errno2Inoutres; {$endif} End; {$endif} Procedure Do_Truncate(Handle,Pos:longint); {$ifndef crtlib} {$ifndef bsd} var sr : syscallregs; {$endif} {$endif} begin {$ifndef crtlib} {$ifdef bsd} do_syscall(syscall_nr_ftruncate,handle,pos,0); {$else} sr.reg2:=Handle; sr.reg3:=Pos; syscall(syscall_nr_ftruncate,sr); {$endif} 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 $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 {$ifndef crtlib} oflags : longint; {$endif} 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 } {$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); 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; {$endif} 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 {$ifndef BSD} sr: SysCallRegs; {$endif} Data : array[0..255] of byte; {Large enough for termios info} begin {$ifdef BSD} Do_IsDevice:=(do_SysCall(syscall_nr_ioctl,handle,$5401,longint(@data))=0); {$else} sr.reg2:=Handle; sr.reg3:=$5401; {=TCGETS} sr.reg4:=Longint(@Data); Do_IsDevice:=(SysCall(Syscall_nr_ioctl,sr)=0); {$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);[IOCheck]; Var Buffer: Array[0..255] of Char; Begin If InOutRes <> 0 then exit; 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);[IOCheck]; Var Buffer: Array[0..255] of Char; Begin If InOutRes <> 0 then exit; 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);[IOCheck]; Var Buffer: Array[0..255] of Char; Begin If InOutRes <> 0 then exit; 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 : shortstring); {$ifndef crtlib} var thisdir : stat; rootino, thisino, dotdotino : longint; rootdev, thisdev, {$ifdef bsd} dotdotdev : longint; {$else} dotdotdev : word; {$endif} thedir,dummy : string[255]; dirstream : pdir; d : pdirent; mountpoint,validdir : boolean; predot : string[255]; {$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); 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) ); if (closedir(dirstream)<0) or (d=nil) then exit; { At this point, d.name contains the name of the current dir} thedir:='/'+strpas(@(d^.name[0]))+thedir; thisdev:=dotdotdev; thisino:=dotdotino; predot:=predot+'../'; end; { Now rootino=thisino and rootdev=thisdev so we've reached / } dir:=thedir {$endif} end; {***************************************************************************** SystemUnit Initialization *****************************************************************************} {$ifdef I386} { this should be defined in i386 directory !! PM } const fpucw : word = $1332; FPU_Invalid = 1; FPU_Denormal = 2; FPU_DivisionByZero = 4; FPU_Overflow = 8; FPU_Underflow = $10; FPU_StackUnderflow = $20; FPU_StackOverflow = $40; {$endif I386} Procedure ResetFPU; begin {$ifdef I386} {$ifndef CORRECTFLDCW} {$asmmode direct} {$endif} asm fninit fldcw fpucw end; {$ifndef CORRECTFLDCW} {$asmmode att} {$endif} {$endif I386} end; {$ifndef BSD} {$ifndef newSignal} Procedure SignalToRunError(Sig:longint); begin case sig of 8 : begin { this is not allways necessary but I don't know yet how to tell if it is or not PM } ResetFPU; HandleError(200); end; 11 : HandleError(216); end; end; Procedure InstallSignals; var sr : syscallregs; begin sr.reg3:=longint(@SignalToRunError); { sigsegv } sr.reg2:=11; syscall(syscall_nr_signal,sr); { sigfpe } sr.reg2:=8; syscall(syscall_nr_signal,sr); end; {$else newSignal} {$i i386/signal.inc} procedure SignalToRunerror(Sig: longint; SigContext: SigContextRec); cdecl; var res,fpustate : word; begin case sig of 8 : begin { this is not allways necessary but I don't know yet how to tell if it is or not PM } {$ifdef I386} fpustate:=0; res:=200; if assigned(SigContext.fpstate) then fpuState:=SigContext.fpstate^.sw; {$ifdef SYSTEMDEBUG} Writeln(stderr,'FpuState = ',Hexstr(FpuState,4)); {$endif SYSTEMDEBUG} if (FpuState and $7f) <> 0 then begin if (FpuState and FPU_Invalid)<>0 then res:=216 else if (FpuState and FPU_Denormal)<>0 then res:=216 else 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 res:=207; {'Coprocessor Error'} end; {$endif I386} ResetFPU; HandleError(res); end; 11 : HandleError(216); end; end; Procedure InstallSignals; const act: SigActionRec = (handler:(Sa:@SignalToRunError);sa_mask:0;sa_flags:0; Sa_restorer: NIL); oldact: PSigActionRec = Nil; begin ResetFPU; SigAction(8,@act,oldact); SigAction(11,@act,oldact); end; {$endif newSignal} {$endif bsd} 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 (isizeof(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 $100, becuase filemode can be upto 255 Revision 1.26 1999/09/08 16:14:43 peter * pointer fixes Revision 1.25 1999/07/28 23:18:36 peter * closedir fixes, which now disposes the pdir itself }