1Unit System; 2 3interface 4 5// Was needed to bootstrap with our old 2.1 fpc for BeOS 6// to define real 7{ $define VER2_0} 8 9{$define FPC_IS_SYSTEM} 10 11{$I sysunixh.inc} 12 13 14type 15 THeapPointer = ^pointer; 16var 17 heapstartpointer : THeapPointer; 18 heapstart : pointer;//external;//external name 'HEAP'; 19 myheapsize : longint; //external;//external name 'HEAPSIZE'; 20 myheaprealsize : longint; 21 heap_handle : longint; 22implementation 23 24procedure debugger(s : PChar); cdecl; external 'root' name 'debugger'; 25 26function disable_debugger(state : integer): integer; external 'root' name 'disable_debugger'; 27//begin 28//end; 29 30{ OS independant parts} 31 32{$I system.inc} 33 34{***************************************************************************** 35 System Dependent Exit code 36*****************************************************************************} 37procedure prthaltproc;external name '_haltproc'; 38 39procedure system_exit; 40begin 41 asm 42 jmp prthaltproc 43 end; 44End; 45 46 47{ OS dependant parts } 48 49{***************************************************************************** 50 Heap Management 51*****************************************************************************} 52 53(*var myheapstart:pointer; 54 myheapsize:longint; 55 myheaprealsize:longint; 56 heap_handle:longint; 57 zero:longint; 58 59 60{ first address of heap } 61function getheapstart:pointer; 62begin 63 getheapstart:=myheapstart; 64end; 65 66{ current length of heap } 67function getheapsize:longint; 68begin 69 getheapsize:=myheapsize; 70end; 71*) 72 73 74(*function getheapstart:pointer; 75assembler; 76asm 77 leal HEAP,%eax 78end ['EAX']; 79 80 81function getheapsize:longint; 82assembler; 83asm 84 movl intern_HEAPSIZE,%eax 85end ['EAX'];*) 86 87{ function to allocate size bytes more for the program } 88{ must return the first address of new data space or nil if fail } 89(*function Sbrk(size : longint):pointer; 90var newsize,newrealsize:longint; 91 s : string; 92begin 93 WriteLn('SBRK'); 94 Str(size, s); 95 WriteLn('size : ' + s); 96 if (myheapsize+size)<=myheaprealsize then 97 begin 98 Sbrk:=pointer(heapstart+myheapsize); 99 myheapsize:=myheapsize+size; 100 exit; 101 end; 102 newsize:=myheapsize+size; 103 newrealsize:=(newsize and $FFFFF000)+$1000; 104 case resize_area(heap_handle,newrealsize) of 105 B_OK : 106 begin 107 WriteLn('B_OK'); 108 Sbrk:=pointer(heapstart+myheapsize); 109 myheapsize:=newsize; 110 myheaprealsize:=newrealsize; 111 exit; 112 end; 113 B_BAD_VALUE : WriteLn('B_BAD_VALUE'); 114 B_NO_MEMORY : WriteLn('B_NO_MEMORY'); 115 B_ERROR : WriteLn('B_ERROR'); 116 else 117 begin 118 Sbrk:=pointer(heapstart+myheapsize); 119 myheapsize:=newsize; 120 myheaprealsize:=newrealsize; 121 exit; 122 end; 123 end; 124 125// Sbrk:=nil; 126end;*) 127 128function sys_resize_area (handle:cardinal; size:longint):longint; cdecl; external name 'sys_resize_area'; 129 130//function sbrk2 (size : longint):pointer; cdecl; external name 'sbrk'; 131 132{ function to allocate size bytes more for the program } 133{ must return the first address of new data space or nil if fail } 134//function Sbrk(size : longint):pointer; 135//var newsize,newrealsize:longint; 136// s : string; 137//begin 138// sbrk := sbrk2(size); 139(* sbrk := nil; 140 WriteLn('sbrk'); 141 Str(size, s); 142 WriteLn('size : ' + s); 143 if (myheapsize+size)<=myheaprealsize then 144 begin 145 Sbrk:=heapstart+myheapsize; 146 myheapsize:=myheapsize+size; 147 exit; 148 end; 149 newsize:=myheapsize+size; 150 newrealsize:=(newsize and $FFFFF000)+$1000; 151 if sys_resize_area(heap_handle,newrealsize+$1000)=0 then 152 begin 153 WriteLn('sys_resize_area OK'); 154 Str(longint(newrealsize), s); 155 WriteLn('newrealsize : $' + Hexstr(longint(newrealsize), 8)); 156 Str(longint(heapstartpointer), s); 157 WriteLn('heapstart : $' + Hexstr(longint(heapstart), 8)); 158 Str(myheapsize, s); 159 WriteLn('myheapsize : ' + s); 160 Str(myheapsize, s); 161 WriteLn('Total : ' + s); 162 WriteLn('Before fillchar'); 163 WriteLn('sbrk : $' + Hexstr(longint(heapstart+myheapsize), 8)); 164 Sbrk:=heapstart+myheapsize; 165 FillChar(sbrk^, size, #0); 166 WriteLn('EndFillChar'); 167 WriteLn('sbrk : $' + Hexstr(longint(sbrk), 8)); 168// ReadLn(s); 169 myheapsize:=newsize; 170 Str({longint(heapstartpointer) +} myheapsize, s); 171 WriteLn('Total : ' + s); 172 myheaprealsize:=newrealsize; 173 exit; 174 end 175 else 176 begin 177 debugger('Bad resize_area'); 178 WriteLn('Bad resize_area'); 179 end; 180 Sbrk:=nil; 181*) 182//end; 183 184{ $I text.inc} 185 186{***************************************************************************** 187 UnTyped File Handling 188*****************************************************************************} 189 190 191{ $i file.inc} 192 193{***************************************************************************** 194 Typed File Handling 195*****************************************************************************} 196 197{ $i typefile.inc} 198 199{***************************************************************************** 200 Misc. System Dependent Functions 201*****************************************************************************} 202 203Function ParamCount: Longint; 204var 205 s : string; 206Begin 207 ParamCount := 0; 208 Paramcount:=argc - 1; 209End; 210 211 { variable where full path and filename and executable is stored } 212 { is setup by the startup of the system unit. } 213var 214 execpathstr : shortstring; 215 216{$ifdef FPC_USE_LIBC} 217 218// private; use the macros, below 219function _get_image_info(image : image_id; var info : image_info; size : size_t) 220 : status_t; cdecl; external 'root' name '_get_image_info'; 221 222function _get_next_image_info(team : team_id; var cookie : Longint; var info : image_info; size : size_t) 223 : status_t; cdecl; external 'root' name '_get_next_image_info'; 224 225function get_image_info(image : image_id; var info : image_info) : status_t; 226begin 227 Result := _get_image_info(image, info, SizeOf(info)); 228end; 229 230function get_next_image_info(team : team_id; var cookie : Longint; var info : image_info) : status_t; 231begin 232 Result := _get_next_image_info(team, cookie, info, SizeOf(info)); 233end; 234 235{$endif} 236 237{ this routine sets up the paramstr(0) string at startup } 238procedure setupexecname; 239var 240 cookie: longint; 241 image : image_info; 242 index : byte; 243 s : string; 244begin 245 cookie:=0; 246 fillchar(image, sizeof(image_info), 0); 247 if get_next_image_info(0, cookie, image) = B_OK then 248 begin 249 execpathstr := strpas(@image.name); 250 end 251 else 252 execpathstr := ''; 253 { problem with Be 4.5 noted... path contains . character } 254 { if file is directly executed in CWD } 255 index:=pos('/./',execpathstr); 256 if index <> 0 then 257 begin 258 { remove the /. characters } 259 Delete(execpathstr,index, 2); 260 end; 261end; 262 263function paramstr(l: longint) : string; 264var 265 s: string; 266 s1: string; 267begin 268 269 { stricly conforming POSIX applications } 270 { have the executing filename as argv[0] } 271 if l = 0 then 272 begin 273 paramstr := execpathstr; 274 end 275 else if (l < argc) then 276 begin 277 paramstr:=strpas(argv[l]); 278 end 279 else 280 paramstr := ''; 281end; 282 283Procedure Randomize; 284Begin 285 randseed:=longint(Fptime(nil)); 286End; 287 288function GetProcessID: SizeUInt; 289begin 290 GetProcessID := SizeUInt (fpGetPID); 291end; 292 293{***************************************************************************** 294 SystemUnit Initialization 295*****************************************************************************} 296 297function reenable_signal(sig : longint) : boolean; 298var 299 e : TSigSet; 300 i,j : byte; 301 olderrno: cint; 302begin 303 fillchar(e,sizeof(e),#0); 304 { set is 1 based PM } 305 dec(sig); 306 i:=sig mod (sizeof(cuLong) * 8); 307 j:=sig div (sizeof(cuLong) * 8); 308 e[j]:=1 shl i; 309 { this routine is called from a signal handler, so must not change errno } 310 olderrno:=geterrno; 311 fpsigprocmask(SIG_UNBLOCK,@e,nil); 312 reenable_signal:=geterrno=0; 313 seterrno(olderrno); 314end; 315 316// signal handler is arch dependant due to processorexception to language 317// exception translation 318 319{$i sighnd.inc} 320 321procedure InstallDefaultSignalHandler(signum: longint; out oldact: SigActionRec); public name '_FPC_INSTALLDEFAULTSIGHANDLER'; 322var 323 act: SigActionRec; 324begin 325 { Initialize the sigaction structure } 326 { all flags and information set to zero } 327 FillChar(act, sizeof(SigActionRec),0); 328 { initialize handler } 329 act.sa_handler := SigActionHandler(@SignalToRunError); 330 act.sa_flags:=SA_SIGINFO; 331 FpSigAction(signum,@act,@oldact); 332end; 333 334var 335 oldsigfpe: SigActionRec; public name '_FPC_OLDSIGFPE'; 336 oldsigsegv: SigActionRec; public name '_FPC_OLDSIGSEGV'; 337 oldsigbus: SigActionRec; public name '_FPC_OLDSIGBUS'; 338 oldsigill: SigActionRec; public name '_FPC_OLDSIGILL'; 339 340Procedure InstallSignals; 341begin 342 InstallDefaultSignalHandler(SIGFPE,oldsigfpe); 343 InstallDefaultSignalHandler(SIGSEGV,oldsigsegv); 344 InstallDefaultSignalHandler(SIGBUS,oldsigbus); 345 InstallDefaultSignalHandler(SIGILL,oldsigill); 346end; 347 348Procedure RestoreOldSignalHandlers; 349begin 350 FpSigAction(SIGFPE,@oldsigfpe,nil); 351 FpSigAction(SIGSEGV,@oldsigsegv,nil); 352 FpSigAction(SIGBUS,@oldsigbus,nil); 353 FpSigAction(SIGILL,@oldsigill,nil); 354end; 355 356 357procedure SysInitStdIO; 358begin 359 { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be 360 displayed in and messagebox } 361 OpenStdIO(Input,fmInput,StdInputHandle); 362 OpenStdIO(Output,fmOutput,StdOutputHandle); 363 OpenStdIO(StdOut,fmOutput,StdOutputHandle); 364 OpenStdIO(StdErr,fmOutput,StdErrorHandle); 365end; 366 367function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; 368begin 369 result := stklen; 370end; 371 372var 373 s : string; 374begin 375 IsConsole := TRUE; 376 StackLength := CheckInitialStkLen(InitialStkLen); 377 StackBottom := Sptr - StackLength; 378 379 { Set up signals handlers (may be needed by init code to test cpu features) } 380 InstallSignals; 381 382{$ifdef cpui386} 383 fpc_cpucodeinit; 384{$endif} 385 386 { Setup heap } 387 myheapsize:=4096*1;// $ 20000; 388 myheaprealsize:=4096*1;// $ 20000; 389 heapstart:=nil; 390 heapstartpointer := nil; 391 heapstartpointer := Sbrk2(4096*1); 392{$IFDEF FPC_USE_LIBC} 393// heap_handle := create_area('fpcheap',heapstart,0,myheaprealsize,0,3);//!! 394{$ELSE} 395// debugger('tata'#0); 396// heap_handle := create_area('fpcheap',longint(heapstartpointer),0,myheaprealsize,0,3);//!! 397// case heap_handle of 398// B_BAD_VALUE : WriteLn('B_BAD_VALUE'); 399// B_PAGE_SIZE : WriteLn('B_PAGE_SIZE'); 400// B_NO_MEMORY : WriteLn('B_NO_MEMORY'); 401// B_ERROR : WriteLn('B_ERROR'); 402// end; 403 404 FillChar(heapstartpointer^, myheaprealsize, #0); 405// WriteLn('EndFillChar'); 406// WriteLn('P : $' + Hexstr(longint(heapstartpointer), 8)); 407// WriteLn('heapstart : $' + Hexstr(longint(heapstartpointer^), 8)); 408 heapstart := heapstartpointer; 409{$ENDIF} 410// WriteLn('before InitHeap'); 411// case heap_handle of 412// B_BAD_VALUE : WriteLn('B_BAD_VALUE'); 413// B_PAGE_SIZE : WriteLn('B_PAGE_SIZE'); 414// B_NO_MEMORY : WriteLn('B_NO_MEMORY'); 415// B_ERROR : WriteLn('B_ERROR'); 416// else 417// begin 418// WriteLn('ok'); 419// WriteLn('P : $' + Hexstr(longint(heapstartpointer), 8)); 420// WriteLn('heapstart : $' + Hexstr(longint(heapstartpointer^), 8)); 421// if heap_handle>0 then 422// begin 423 InitHeap; 424// end; 425// end; 426// end; 427// WriteLn('after InitHeap'); 428// end else system_exit; 429 SysInitExceptions; 430// WriteLn('after SysInitException'); 431 432 initunicodestringmanager; 433{ Setup IO } 434 SysInitStdIO; 435{ Reset IO Error } 436 InOutRes:=0; 437 InitSystemThreads; 438 InitSystemDynLibs; 439 setupexecname; 440 { restore original signal handlers in case this is a library } 441 if IsLibrary then 442 RestoreOldSignalHandlers; 443end. 444