{ $Id$ This file is part of the Free Pascal Run time library. Copyright (c) 1993,97 by 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. **********************************************************************} {**************************************************************************** Local types ****************************************************************************} { TextRec and FileRec are put in a separate file to make it available to other units without putting it explicitly in systemh. This way we keep TP compatibility, and the TextRec definition is available for everyone who needs it. } {$i filerec.inc} {$i textrec.inc} Procedure HandleError (Errno : Longint); forward; type FileFunc = Procedure(var t : TextRec); const { Random / Randomize constants } OldRandSeed : Longint = 0; InitialSeed : Boolean = TRUE; Seed1 : Longint = 0; Seed2 : Longint = 0; Seed3 : Longint = 0; { For Error Handling.} DoError : Boolean = FALSE; ErrorBase : Longint = 0; {**************************************************************************** Include processor specific routines ****************************************************************************} {$IFDEF I386} {$IFDEF M68K} {$Error Can't determine processor type !} {$ENDIF} {$I i386.inc} { Case dependent, don't change } {$ELSE} {$IFDEF M68K} {$I m68k.inc} { Case dependent, don't change } {$ELSE} {$Error Can't determine processor type !} {$ENDIF} {$ENDIF} {**************************************************************************** Routines which have compiler magic ****************************************************************************} {$I innr.inc} Function lo(i : Integer) : byte; [INTERNPROC: In_lo_Word]; Function lo(w : Word) : byte; [INTERNPROC: In_lo_Word]; Function lo(l : Longint) : Word; [INTERNPROC: In_lo_long]; Function hi(i : Integer) : byte; [INTERNPROC: In_hi_Word]; Function hi(w : Word) : byte; [INTERNPROC: In_hi_Word]; Function hi(l : Longint) : Word; [INTERNPROC: In_hi_long]; {$ifdef VER0_99_5} Procedure Inc(var i : Cardinal); [INTERNPROC: In_Inc_DWord]; Procedure Inc(var i : Longint); [INTERNPROC: In_Inc_DWord]; Procedure Inc(var i : Integer); [INTERNPROC: In_Inc_Word]; Procedure Inc(var i : Word); [INTERNPROC: In_Inc_Word]; Procedure Inc(var i : shortint); [INTERNPROC: In_Inc_byte]; Procedure Inc(var i : byte); [INTERNPROC: In_Inc_byte]; Procedure Inc(var c : Char); [INTERNPROC: In_Inc_byte]; Procedure Inc(var p : PChar); [INTERNPROC: In_Inc_DWord]; Procedure Dec(var i : Cardinal); [INTERNPROC: In_Dec_DWord]; Procedure Dec(var i : Longint); [INTERNPROC: In_Dec_DWord]; Procedure Dec(var i : Integer); [INTERNPROC: In_Dec_Word]; Procedure Dec(var i : Word); [INTERNPROC: In_Dec_Word]; Procedure Dec(var i : shortint); [INTERNPROC: In_Dec_byte]; Procedure Dec(var i : byte); [INTERNPROC: In_Dec_byte]; Procedure Dec(var c : Char); [INTERNPROC: In_Dec_byte]; Procedure Dec(var p : PChar); [INTERNPROC: In_Dec_DWord]; {$endif VER0_99_5} Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte]; Function Length(s : string) : byte; [INTERNPROC: In_Length_string]; Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile]; Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile]; {**************************************************************************** Set Handling ****************************************************************************} { Include set support which is processor specific} {$I set.inc} {**************************************************************************** Subroutines for String handling ****************************************************************************} { Needs to be before RTTI handling } {$i sstrings.inc} {$ifdef UseAnsiStrings} Type PLongint = ^Longint; PByte = ^Byte; {$i astrings.pp} {$else} { Provide dummy procedures needed for rtti} Procedure decr_ansi_ref (P : pointer);[Alias : 'DECR_ANSI_REF']; begin end; Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF']; begin end; {$endif} {**************************************************************************** Run-Time Type Information (RTTI) ****************************************************************************} {$ifndef VER0_99_5} {$i rtti.inc} {$endif VER0_99_5} {**************************************************************************** Math Routines ****************************************************************************} {$ifndef RTLLITE} function Hi(b : byte): byte; begin Hi := b shr 4 end; function Lo(b : byte): byte; begin Lo := b and $0f end; {$ifdef VER0_99_5} Procedure Inc(var i : Cardinal;a: Longint); Begin I:=I+A; End; Procedure Dec(var i : Cardinal;a: Longint); Begin I:=I-A; End; Procedure Inc(var i : Longint;a : Longint); Begin i:=i+a; End; Procedure Dec(var i : Longint;a : Longint); Begin i:=i-a; End; Procedure Dec(var i : Word;a : Longint); Begin i:=i-a; End; Procedure Inc(var i : Word;a : Longint); Begin i:=i+a; End; Procedure Dec(var i : Integer;a : Longint); Begin i:=i-a; End; Procedure Inc(var i : Integer;a : Longint); Begin i:=i+a; End; Procedure Dec(var i : byte;a : Longint); Begin i:=i-a; End; Procedure Inc(var i : byte;a : Longint); Begin i:=i+a; End; Procedure Dec(var i : shortint;a : Longint); Begin i:=i-a; End; Procedure Inc(var i : shortint;a : Longint); Begin i:=i+a; End; Procedure Dec(var c : Char;a : Longint); Begin byte(c):=byte(c)-a; End; Procedure Inc(var c : Char;a : Longint); Begin Byte(c):=byte(c)+a; End; Procedure Dec(var p : PChar;a : Longint); Begin longint(p):=longint(p)-a; End; Procedure Inc(var p : PChar;a : Longint); Begin longint(p):=longint(p)+a; End; {$endif VER0_99_5} Function swap (X : Word) : Word; Begin swap:=(X and $ff) shl 8 + (X shr 8) End; Function Swap (X : Integer) : Integer; Begin Swap:=Integer(Swap(Word(X))); End; Function swap (X : Longint) : Longint; Begin Swap:=(X and $ffff) shl 16 + (X shr 16) End; Function Swap (X : Cardinal) : Cardinal; Begin Swap:=Swap(Longint(X)); End; {$endif RTLLITE} {**************************************************************************** Random function routines This implements a very long cycle random number generator by combining three independant generators. The technique was described in the March 1987 issue of Byte. Taken and modified with permission from the PCQ Pascal rtl code. ****************************************************************************} {$R-} {$Q-} { PLEASE DO NOT OPTIMIZE BECAUSE THEY ACTUALLY WORK CORRECTLY - unless } { you want me to go violent :) (CEC) } Procedure UseSeed(seed : Longint);Forward; Function Random : Real; var ReturnValue : Real; begin if (InitialSeed) OR ((RandSeed <> OldRandSeed) AND NOT InitialSeed) then Begin OldRandSeed:=RandSeed; { This is a pretty complicated affair } { Initially we must call UseSeed when RandSeed is initalized } { We must also call UseSeed each time RandSeed is reinitialized } { DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK } { UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC) } InitialSeed:=FALSE; UseSeed(Randseed); end; Inc(Seed1); Seed1 := (Seed1 * 706) mod 500009; INC(Seed2); Seed2 := (Seed2 * 774) MOD 600011; INC(Seed3); Seed3 := (Seed3 * 871) MOD 765241; ReturnValue := Seed1/500009.0 + Seed2/600011.0 + Seed3/765241.0; Random := frac(ReturnValue); end; Function Random(l : Longint) : Longint; begin if (InitialSeed) OR ((RandSeed <> OldRandSeed) AND NOT InitialSeed) then Begin OldRandSeed:=RandSeed; { This is a pretty complicated affair } { Initially we must call UseSeed when RandSeed is initalized } { We must also call UseSeed each time RandSeed is reinitialized } { DO NOT CHANGE THE ORDER OF DECLARATIONS IN THIS BLOCK } { UNLESS YOU WANT RANDON TO CRASH OF COURSE (CEC) } InitialSeed:=FALSE; UseSeed(Randseed); end; Inc(Seed1); Seed1 := (Seed1 * 998) mod 1000003; Random := Seed1 mod l; end; Procedure UseSeed(seed : Longint); begin Seed1 := seed mod 1000003; Seed2 := (Random(65000) * Random(65000)) mod 600011; Seed3 := (Random(65000) * Random(65000)) mod 765241; end; { Include processor specific routines } {$I math.inc} {**************************************************************************** Memory Management ****************************************************************************} {$ifndef RTLLITE} Function Ptr(sel,off : Longint) : pointer; Begin sel:=0; ptr:=pointer(off); End; Function Addr (Var X) : Pointer; Begin Addr:=@(X); End; Function CSeg : Word; Begin Cseg:=0; End; Function DSeg : Word; Begin Dseg:=0; End; Function SSeg : Word; Begin Sseg:=0; End; {$endif RTLLITE} {***************************************************************************** Miscellaneous *****************************************************************************} Function IOResult:Word; Begin IOResult:=InOutRes; InOutRes:=0; End; procedure fillchar(var x;count : longint;value : char); begin fillchar(x,count,byte(value)); end; {***************************************************************************** Init / Exit / ExitProc *****************************************************************************} Procedure RunError; Begin RunError (0); End; Procedure Halt; Begin Halt(0); End; Procedure dump_stack(bp : Longint); Procedure dump_frame(addr : Longint); Begin {To be used by symify} Writeln(stderr,' 0x',HexStr(addr,8)); {$ifdef VER0_99_5} Flush(stderr); {$endif VER0_99_5} End; var i, prevbp : Longint; Begin prevbp:=bp-1; i:=0; while bp > prevbp Do Begin dump_frame(get_addr(bp)); Inc(i); If i>max_frame_dump Then exit; prevbp:=bp; bp:=get_next_frame(bp); End; End; Procedure Do_exit;[Public,Alias: '__EXIT']; { Don't call this direct, the call is generated by the compiler } var current_exit : Procedure; Begin while exitProc<>nil Do Begin InOutRes:=0; current_exit:=tProcedure(exitProc); exitProc:=nil; current_exit(); End; If DoError Then Begin Writeln('Run time error ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8)); dump_stack(ErrorBase); End; {$ifdef VER0_99_5} Flush(stderr); {$endif VER0_99_5} End; Type PExitProcInfo = ^TExitProcInfo; TExitProcInfo = Record Next : PExitProcInfo; SaveExit : Pointer; Proc : TProcedure; End; const ExitProcList: PExitProcInfo = nil; Procedure DoExitProc; var P : PExitProcInfo; Proc : TProcedure; Begin P:=ExitProcList; ExitProcList:=P^.Next; ExitProc:=P^.SaveExit; Proc:=P^.Proc; DisPose(P); Proc(); End; Procedure AddExitProc(Proc: TProcedure); var P : PExitProcInfo; Begin New(P); P^.Next:=ExitProcList; P^.SaveExit:=ExitProc; P^.Proc:=Proc; ExitProcList:=P; ExitProc:=@DoExitProc; End; {***************************************************************************** Assert() support. *****************************************************************************} Procedure do_assert (Const Name,Msg : string; LineNo : Longint); [Public,Alias : 'FPC_DO_ASSERT']; begin If msg='' then write (stderr,'Assertion failed. ') else write (stderr,msg); writeln (stderr,'(File : ',name,', line ',LineNo,'.'); flush (stderr); HandleError (227); end; {***************************************************************************** SetJmp/LongJmp support. *****************************************************************************} {$i setjump.inc} {***************************************************************************** Exception support. *****************************************************************************} { No go, because objpas needed :( (MVC) } { $i except.inc} { $Log$ Revision 1.27 1998-08-13 16:22:11 jonas * random now returns a value between 0 and max-1 instead of between 0 and max Revision 1.26 1998/08/11 00:05:26 peter * $ifdef ver0_99_5 updates Revision 1.25 1998/07/30 13:26:18 michael + Added support for ErrorProc variable. All internal functions are required to call HandleError instead of runerror from now on. This is necessary for exception support. Revision 1.24 1998/07/28 20:37:45 michael + added setjmp/longjmp and exception support Revision 1.23 1998/07/23 19:53:20 michael + Adapted assert to Delphi format Revision 1.22 1998/07/23 13:08:41 michael + Implemented DO_ASSERT function. Revision 1.21 1998/07/15 12:09:35 carl * would not compile under FPC v0.99.5 Revision 1.20 1998/07/13 21:19:12 florian * some problems with ansi string support fixed Revision 1.19 1998/07/08 11:56:55 carl * randon and Random(l) now work correctly - don't touch it works! Revision 1.18 1998/07/02 13:01:55 carl * hmmm... it is luck (BSS zeroed with GAS) that DoError and ErrorBase work. Now they are initilized instead. Revision 1.17 1998/07/02 12:53:09 carl * DOERROR RESOTRED! DON'T TOUCH :) Revision 1.16 1998/07/02 12:11:50 carl * no SINGLE in m68k and other processors! Revision 1.15 1998/07/02 09:25:05 peter * fixed do_error in runtimeerror Revision 1.14 1998/07/01 15:29:59 peter * better readln/writeln Revision 1.13 1998/06/26 08:21:09 daniel - Doerror removed. Revision 1.12 1998/06/25 14:04:25 peter + internal inc/dec Revision 1.11 1998/06/25 09:44:20 daniel + RTLLITE directive to compile minimal RTL. Revision 1.10 1998/06/15 15:16:26 daniel * RTLLITE conditional added to produce smaller RTL Revision 1.9 1998/06/10 07:46:45 michael + Forgot to commit some changes Revision 1.8 1998/06/08 12:38:24 michael Implemented rtti, inserted ansistrings again Revision 1.7 1998/06/04 23:46:01 peter * comp,extended are only i386 added support_comp,support_extended Revision 1.6 1998/05/20 11:23:09 cvs * test commit. Shouldn't be allowed. Revision 1.5 1998/05/12 10:42:45 peter * moved getopts to inc/, all supported OS's need argc,argv exported + strpas, strlen are now exported in the systemunit * removed logs * removed $ifdef ver_above Revision 1.4 1998/04/16 12:30:47 peter + inc(pchar), dec(pchar), incc(pchar,a),dec(pchar,a) Revision 1.3 1998/04/08 07:53:32 michael + Changed Random() function. Moved from system to processor dependent files (from Pedro Gimeno) }