paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-16 10:26:02 +02:00
Code Issues Packages Projects Releases Wiki Activity
e18075dc19
fpc/rtl/inc/system.inc

563 lines
15 KiB
PHP
Raw Blame History

{
$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}
type
FileFunc = Procedure(var t : TextRec);
var
{ For Error Handling.}
DoError : Boolean;
ErrorBase : Longint;
{****************************************************************************
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];
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 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];
{$IFNDEF ORDINTERN}
Function ord(c : Char) : byte; [INTERNPROC: In_ord_Char];
{$ENDIF ORDINTERN}
Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte];
Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
{$IFDEF VER_ABOVE0_9_5}
Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{$ENDIF}
{****************************************************************************
Math Routines
****************************************************************************}
function Hi(b : byte): byte;
begin
Hi := b shr 4
end;
function Lo(b : byte): byte;
begin
Lo := b and $0f
end;
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;
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;
{$R-}
Function Random(l : Longint) : Longint;
{
the problem Wwth this Function is if l is maxLongint*3/4 then the
probability to obtain a number in the range maxlongint*1/4 to maxlongint*1/2
is two times smaller than the probability for other numbers !
}
Begin
Randseed:=Randseed*134775813+1;
Random:=abs(Randseed mod l);
End;
Function Random : real;
{
I am not sure about the accuracy of such a value (PM)
}
Begin
Random:=abs(Randseed);
Random:=Random/(maxLongint+1.0);
Randseed:=Randseed*134775813+1;
Random:=(abs(Randseed)+Random)/(maxLongint+2.0);
End;
{ Include processor specific routines }
{$I math.inc}
{****************************************************************************
Set Handling
****************************************************************************}
{ Include set support which is processor specific}
{$I set.inc}
{****************************************************************************
Memory Management
****************************************************************************}
Function Ptr(sel,off : Longint) : pointer;
Begin
sel:=0;
{$IFDEF DoMapping}
{$IFDEF DoS}
ptr:=pointer($e0000000+sel shl 4+off);
{$ELSE}
ptr:=pointer(sel shl 4+off);
{$ENDIF}
{$ELSE}
ptr:=pointer(off);
{$ENDIF}
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;
{****************************************************************************
Subroutines for short strings are in sstrings.inc
****************************************************************************}
{$i sstrings.inc}
{*****************************************************************************
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 Initexception;[Public,Alias: 'INITEXCEPTION'];
Begin
Writeln('Exception occurred during program initialization.');
halt(216);
End;
Procedure dump_stack(bp : Longint);
Procedure dump_frame(addr : Longint);
Begin
{To be used by symify}
Writeln(stderr,' 0x',HexStr(addr,8));
Flush(stderr);
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;
{ this is wrong at least for dos !!!
in dos input output and stderr must be left open !! }
{$ifndef DOS}
{$ifndef GO32V2}
Close(Output);
Close(StdErr);
{$endif GO32V2}
{$endif DOS}
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;
{
$Log$
Revision 1.2 1998-03-25 23:39:17 florian
* complete Object Pascal support moved to objpas unit
Revision 1.1.1.1 1998/03/25 11:18:43 root
* Restored version
Revision 1.29 1998/02/07 05:31:22 carl
* bugfix of Swap with cardinal (no return value was set)
Revision 1.28 1998/01/30 17:19:18 pierre
* output and stderr must not be closed at exit under dos
Revision 1.27 1998/01/26 11:59:53 michael
+ Added log at the end
Working file: rtl/inc/system.inc
description:
----------------------------
revision 1.26
date: 1998/01/23 22:21:49; author: michael; state: Exp; lines: +18 -6
+ Set up things for Delphi Object model under DELPHI_EXTENSIONS
----------------------------
revision 1.25
date: 1998/01/20 09:14:35; author: michael; state: Exp; lines: +13 -1
+ implemented Hi and Lo for bytes. SHould be made an internalproc, though.
----------------------------
revision 1.24
date: 1998/01/19 10:21:32; author: michael; state: Exp; lines: +10 -1
* moved Fillchar t(..,char) to system.inc
----------------------------
revision 1.23
date: 1998/01/16 17:58:51; author: florian; state: Exp; lines: +8 -2
* basic tobject added (create, destroy and free)
----------------------------
revision 1.22
date: 1998/01/11 02:45:43; author: michael; state: Exp; lines: +322 -1380
+ Moved file operations to
- file.inc : Untyped file handling
- text.inc text file handling
- typefile.inc typed file handling
- version stuff to version.inc
By Peter Vreman.
----------------------------
revision 1.21
date: 1998/01/06 00:29:33; author: michael; state: Exp; lines: +45 -81
Implemented a system independent sequence of reset/rewrite/append fileopenfunc etc system \n (from Peter Vreman)
----------------------------
revision 1.20
date: 1998/01/05 12:32:14; author: michael; state: Exp; lines: +143 -748
* Undid changes by Carl, it rendered the system unit unusable !
----------------------------
revision 1.19
date: 1998/01/05 00:47:10; author: carl; state: Exp; lines: +748 -143
+ Compatible with m68k floating point types
+ Test68000/Test68882 variables added when in m68k mode
----------------------------
revision 1.18
date: 1998/01/03 00:44:19; author: michael; state: Exp; lines: +6 -25
* Shorter WRITE_TEXT_BOOLEAN (From Peter Vreman)
- Removed unused vars in READ_TEXT_CHAR (From Peter Vreman)
- Removed 'far' from DoExitProc (From Peter Vreman)
----------------------------
revision 1.17
date: 1998/01/01 16:56:08; author: michael; state: Exp; lines: +60 -1
+ Implemented Addr() function.
+ Implemented Inc/Dec for cardinal
+ Implemented Inc/Dec (C : Char; A : longint);
----------------------------
revision 1.16
date: 1997/12/24 14:08:38; author: michael; state: Exp; lines: +7 -2
+ Added SSEG function, (From Peter Vreman)
* fixed bug in append, default filehandle should be 1, not 0 (From Peter
Vreman)
----------------------------
revision 1.15
date: 1997/12/23 16:32:21; author: michael; state: Exp; lines: +24 -26
* More efficient treating of append, reset and rewrite (From Peter Vreman)
----------------------------
revision 1.14
date: 1997/12/22 18:53:18; author: michael; state: Exp; lines: +6 -752
+ All 255-length string handling routines have been moved to sstrings.inc.
----------------------------
revision 1.13
date: 1997/12/22 15:35:30; author: michael; state: Exp; lines: +10 -9
* Fixed bug introduced by previous commit.
----------------------------
revision 1.12
date: 1997/12/22 11:11:54; author: michael; state: Exp; lines: +138 -86
* Implemented better (faster) string handling routines from Peter Vreman.
----------------------------
revision 1.11
date: 1997/12/22 10:44:26; author: pierre; state: Exp; lines: +5 -5
* tipping error in READ_TEXT_INTEGER and so on
----------------------------
revision 1.10
date: 1997/12/19 11:37:55; author: pierre; state: Exp; lines: +53 -1
* added read_text for integer word byte and shortint
----------------------------
revision 1.9
date: 1997/12/11 11:45:32; author: michael; state: Exp; lines: +45 -45
+ undid changes to pos/delete/copy/insert. Version 1.8 was UNUSABLE.
----------------------------
revision 1.8
date: 1997/12/10 12:13:20; author: michael; state: Exp; lines: +89 -89
* changed DateiFunc to FileFunc
----------------------------
revision 1.7
date: 1997/12/02 16:08:53; author: pierre; state: Exp; lines: +7 -1
* bug fix in val(string,longint,word) for '-2147483648'
----------------------------
revision 1.6
date: 1997/12/01 12:08:05; author: michael; state: Exp; lines: +10 -4
+ added copyright reference header.
----------------------------
revision 1.5
date: 1997/11/28 19:45:22; author: pierre; state: Exp; lines: +14 -12
* one more bug fix with namelength
+ fixed math in fixed_math define (does not compile yet)
----------------------------
revision 1.4
date: 1997/11/28 12:21:51; author: michael; state: Exp; lines: +2 -2
Removed the WRITE_TEXT_CARDINAL for version 0.9.1 and less.
----------------------------
revision 1.3
date: 1997/11/27 22:49:05; author: florian; state: Exp; lines: +5 -0
- CPU.PP added
- some bugs in DOS fixed (espsecially for go32v1)
- the win32 system unit is now compilable
----------------------------
revision 1.2
date: 1997/11/27 16:29:37; author: michael; state: Exp; lines: +3 -3
Change submitted by Pierre Muller:
Added check : version must be above 0.9.7 for extended type
handling functions.
----------------------------
revision 1.1
date: 1997/11/27 08:33:47; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:47; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}
Reference in New Issue View Git Blame Copy Permalink