1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
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.
**********************************************************************}
{ exported by the system unit }
function get_fsr : dword;external name 'FPC_GETFSR';
procedure set_fsr(fsr : dword);external name 'FPC_SETFSR';
function GetRoundMode: TFPURoundingMode;
const
bits2rm: array[0..3] of TFPURoundingMode = (rmNearest,rmTruncate,rmUp,rmDown);
begin
result:=TFPURoundingMode(bits2rm[(get_fsr shr 30) and 3])
end;
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
const
rm2bits: array[TFPURoundingMode] of byte = (0,3,2,1);
var
cw: dword;
begin
cw:=get_fsr;
result:=TFPURoundingMode(cw shr 30);
set_fsr((cw and $3fffffff) or (rm2bits[RoundMode] shl 30));
end;
function GetPrecisionMode: TFPUPrecisionMode;
begin
result:=pmDouble;
end;
function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
begin
result:=pmDouble;
end;
function FSR2ExceptionMask(fsr: dword): TFPUExceptionMask;
begin
result:=[];
{ invalid operation: bit 27 }
if (fsr and (1 shl 27))=0 then
include(result,exInvalidOp);
{ zero divide: bit 24 }
if (fsr and (1 shl 24))=0 then
include(result,exZeroDivide);
{ overflow: bit 26 }
if (fsr and (1 shl 26))=0 then
include(result,exOverflow);
{ underflow: bit 25 }
if (fsr and (1 shl 25))=0 then
include(result,exUnderflow);
{ Precision (inexact result): bit 23 }
if (fsr and (1 shl 23))=0 then
include(result,exPrecision);
end;
function GetExceptionMask: TFPUExceptionMask;
begin
result:=FSR2ExceptionMask(get_fsr);
end;
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
var
fsr : dword;
begin
fsr:=get_fsr;
result:=FSR2ExceptionMask(fsr);
{ invalid operation: bit 27 }
if (exInvalidOp in mask) then
fsr:=fsr and not(1 shl 27)
else
fsr:=fsr or (1 shl 27);
{ zero divide: bit 24 }
if (exZeroDivide in mask) then
fsr:=fsr and not(1 shl 24)
else
fsr:=fsr or (1 shl 24);
{ overflow: bit 26 }
if (exOverflow in mask) then
fsr:=fsr and not(1 shl 26)
else
fsr:=fsr or (1 shl 26);
{ underflow: bit 25 }
if (exUnderflow in mask) then
fsr:=fsr and not(1 shl 25)
else
fsr:=fsr or (1 shl 25);
{ Precision (inexact result): bit 23 }
if (exPrecision in mask) then
fsr:=fsr and not(1 shl 23)
else
fsr:=fsr or (1 shl 23);
{ update control register contents }
set_fsr(fsr);
end;
procedure ClearExceptions(RaisePending: Boolean =true);
begin
set_fsr(get_fsr and $fffffc1f);
end;
|
