1{ 2 This file is part of the Free Pascal run time library. 3 Copyright (c) 2019 the Free Pascal development team. 4 5 System unit for Haiku 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 **********************************************************************} 15 16 17Unit System; 18 19interface 20 21{$define FPC_IS_SYSTEM} 22 23{$I sysunixh.inc} 24 25implementation 26 27var 28 initialstkptr : Pointer; external name '__stkptr'; 29 30procedure debugger(s : PChar); cdecl; external 'root' name 'debugger'; 31function disable_debugger(state : integer): integer; cdecl; external 'root' name 'disable_debugger'; 32 33 34{ OS independant parts} 35 36{$I system.inc} 37 38{***************************************************************************** 39 System Dependent Exit code 40*****************************************************************************} 41{$ifdef legacy_startup} 42procedure prthaltproc;external name '_haltproc'; 43 44procedure system_exit; 45begin 46 asm 47 jmp prthaltproc 48 end; 49End; 50{$else legacy_startup} 51procedure haltproc(exitcode: longint); cdecl; external name '_haltproc'; 52 53procedure system_exit; 54begin 55 haltproc(ExitCode); 56end; 57{$endif legacy_startup} 58 59 60{ OS dependant parts } 61 62 63{ $I text.inc} 64 65{***************************************************************************** 66 UnTyped File Handling 67*****************************************************************************} 68 69{ $i file.inc} 70 71{***************************************************************************** 72 Typed File Handling 73*****************************************************************************} 74 75{ $i typefile.inc} 76 77{***************************************************************************** 78 Misc. System Dependent Functions 79*****************************************************************************} 80 81Function ParamCount: Longint; 82Begin 83 Paramcount := argc - 1; 84End; 85 86 { variable where full path and filename and executable is stored } 87 { is setup by the startup of the system unit. } 88var 89 execpathstr : shortstring; 90 91{$ifdef FPC_USE_LIBC} 92 93// private; use the macros, below 94function _get_image_info(image : image_id; var info : image_info; size : size_t) 95 : status_t; cdecl; external 'root' name '_get_image_info'; 96 97function _get_next_image_info(team : team_id; var cookie : Longint; var info : image_info; size : size_t) 98 : status_t; cdecl; external 'root' name '_get_next_image_info'; 99 100function get_image_info(image : image_id; var info : image_info) : status_t; 101begin 102 Result := _get_image_info(image, info, SizeOf(info)); 103end; 104 105function get_next_image_info(team : team_id; var cookie : Longint; var info : image_info) : status_t; 106begin 107 Result := _get_next_image_info(team, cookie, info, SizeOf(info)); 108end; 109 110{$endif} 111 112{ this routine sets up the paramstr(0) string at startup } 113procedure setupexecname; 114var 115 cookie: longint; 116 image : image_info; 117 index : byte; 118 s : string; 119begin 120 cookie:=0; 121 fillchar(image, sizeof(image_info), 0); 122 if get_next_image_info(0, cookie, image) = B_OK then 123 begin 124 execpathstr := strpas(@image.name); 125 end 126 else 127 execpathstr := ''; 128 { problem with Be 4.5 noted... path contains . character } 129 { if file is directly executed in CWD } 130 index:=pos('/./',execpathstr); 131 if index <> 0 then 132 begin 133 { remove the /. characters } 134 Delete(execpathstr,index, 2); 135 end; 136end; 137 138function paramstr(l: longint) : string; 139var 140 s: string; 141 s1: string; 142begin 143 { stricly conforming POSIX applications } 144 { have the executing filename as argv[0] } 145 if l = 0 then 146 begin 147 paramstr := execpathstr; 148 end 149 else if (l < argc) then 150 begin 151 paramstr:=strpas(argv[l]); 152 end 153 else 154 paramstr := ''; 155end; 156 157Procedure Randomize; 158Begin 159 randseed:=longint(Fptime(nil)); 160End; 161 162function GetProcessID: SizeUInt; 163begin 164 GetProcessID := SizeUInt (fpGetPID); 165end; 166 167{***************************************************************************** 168 SystemUnit Initialization 169*****************************************************************************} 170 171function reenable_signal(sig : longint) : boolean; 172var 173 e : TSigSet; 174 i,j : byte; 175 olderrno: cint; 176begin 177 fillchar(e,sizeof(e),#0); 178 { set is 1 based PM } 179 dec(sig); 180 i:=sig mod (sizeof(cuLong) * 8); 181 j:=sig div (sizeof(cuLong) * 8); 182 e[j]:=1 shl i; 183 { this routine is called from a signal handler, so must not change errno } 184 olderrno:=geterrno; 185 fpsigprocmask(SIG_UNBLOCK,@e,nil); 186 reenable_signal:=geterrno=0; 187 seterrno(olderrno); 188end; 189 190// signal handler is arch dependant due to processorexception to language 191// exception translation 192 193{$i sighnd.inc} 194 195procedure set_signal_stack(ptr : pointer; size : size_t); cdecl; external 'root' name 'set_signal_stack'; 196function sigaltstack(const stack : pstack_t; oldStack : pstack_t) : integer; cdecl; external 'root' name 'sigaltstack'; 197 198type 199 {$PACKRECORDS C} 200 TAlternateSignalStack = record 201 case Integer of 202 0 : (buffer : array[0..(SIGSTKSZ * 4)-1] of Char); 203 1 : (ld : clonglong); 204 2 : (l : integer); 205 3 : (p : pointer); 206 end; 207 208var 209 alternate_signal_stack : TAlternateSignalStack; 210 211procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER'; 212var 213 r : integer; 214 st : stack_t; 215 act : SigActionRec; 216begin 217 st.ss_flags := 0; 218 st.ss_sp := @alternate_signal_stack.buffer; 219 st.ss_size := SizeOf(alternate_signal_stack.buffer); 220 221 r := sigaltstack(@st, nil); 222 223 if (r <> 0) then 224 begin 225 debugger('sigaltstack error'); 226 end; 227 228 { Initialize the sigaction structure } 229 { all flags and information set to zero } 230 FillChar(act, sizeof(SigActionRec), #0); 231 { initialize handler } 232 act.sa_mask[0] := 0; 233 act.sa_handler := SigActionHandler(@SignalToRunError); 234 act.sa_flags := SA_ONSTACK or SA_SIGINFO; 235 FpSigAction(signum,@act,@oldact); 236end; 237 238var 239 oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE'; 240 oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV'; 241 oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS'; 242 oldsigill: SigActionRec; public name '_FPC_OLDSIGILL'; 243 244Procedure InstallSignals; 245begin 246 InstallDefaultSignalHandler(SIGFPE,oldsigfpe); 247 InstallDefaultSignalHandler(SIGSEGV,oldsigsegv); 248 InstallDefaultSignalHandler(SIGBUS,oldsigbus); 249 InstallDefaultSignalHandler(SIGILL,oldsigill); 250end; 251 252Procedure RestoreOldSignalHandlers; 253begin 254 FpSigAction(SIGFPE,@oldsigfpe,nil); 255 FpSigAction(SIGSEGV,@oldsigsegv,nil); 256 FpSigAction(SIGBUS,@oldsigbus,nil); 257 FpSigAction(SIGILL,@oldsigill,nil); 258end; 259 260procedure SysInitStdIO; 261begin 262 { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be 263 displayed in and messagebox } 264 OpenStdIO(Input,fmInput,StdInputHandle); 265 OpenStdIO(Output,fmOutput,StdOutputHandle); 266 OpenStdIO(StdOut,fmOutput,StdOutputHandle); 267 OpenStdIO(StdErr,fmOutput,StdErrorHandle); 268end; 269 270function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; 271begin 272 result := stklen; 273end; 274 275begin 276 IsConsole := TRUE; 277 StackLength := CheckInitialStkLen(InitialStkLen); 278{$if FPC_FULLVERSION >= 30301} 279 StackBottom := initialstkptr - StackLength; 280{$else} 281 StackBottom := Sptr - StackLength; 282{$endif} 283 ReturnNilIfGrowHeapFails := False; 284 285 { Set up signals handlers } 286 InstallSignals; 287 288{$ifdef cpui386} 289 fpc_cpucodeinit; 290{$endif} 291 292 { Setup heap } 293 InitHeap; 294 295 SysInitExceptions; 296 initunicodestringmanager; 297 { Setup IO } 298 SysInitStdIO; 299 { Reset IO Error } 300 InOutRes:=0; 301 InitSystemThreads; 302 InitSystemDynLibs; 303 setupexecname; 304 305 { restore original signal handlers in case this is a library } 306 if IsLibrary then 307 RestoreOldSignalHandlers; 308end. 309