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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
|
{
$Id: math.inc,v 1.24 2005/03/13 17:14:46 florian Exp $
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2001 by the Free Pascal development team
Implementation of mathematical routines (for extended type)
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.
**********************************************************************}
{****************************************************************************
FPU Control word
****************************************************************************}
procedure Set8087CW(cw:word);assembler;
asm
{$ifndef REGCALL}
movw cw,%ax
{$endif}
movw %ax,default8087cw
fnclex
fldcw default8087cw
end;
function Get8087CW:word;assembler;
asm
pushl $0
fnstcw (%esp)
popl %eax
end;
{****************************************************************************
EXTENDED data type routines
****************************************************************************}
{$ifdef INTERNCONSTINTF}
{$define FPC_SYSTEM_HAS_PI}
function fpc_pi_real : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_ABS}
function fpc_abs_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_SQR}
function fpc_sqr_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_SQRT}
function fpc_sqrt_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_ARCTAN}
function fpc_arctan_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_LN}
function fpc_ln_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_SIN}
function fpc_sin_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$define FPC_SYSTEM_HAS_COS}
function fpc_cos_real(d : ValReal) : ValReal;compilerproc;
begin
{ Function is handled internal in the compiler }
runerror(207);
result:=0;
end;
{$else}
{$define FPC_SYSTEM_HAS_PI}
function pi : ValReal;[internproc:fpc_in_pi];
{$define FPC_SYSTEM_HAS_ABS}
function abs(d : ValReal) : ValReal;[internproc:fpc_in_abs_real];
{$define FPC_SYSTEM_HAS_SQR}
function sqr(d : ValReal) : ValReal;[internproc:fpc_in_sqr_real];
{$define FPC_SYSTEM_HAS_SQRT}
function sqrt(d : ValReal) : ValReal;[internproc:fpc_in_sqrt_real];
{$define FPC_SYSTEM_HAS_ARCTAN}
function arctan(d : ValReal) : ValReal;[internproc:fpc_in_arctan_real];
{$define FPC_SYSTEM_HAS_LN}
function ln(d : ValReal) : ValReal;[internproc:fpc_in_ln_real];
{$define FPC_SYSTEM_HAS_SIN}
function sin(d : ValReal) : ValReal;[internproc:fpc_in_sin_real];
{$define FPC_SYSTEM_HAS_COS}
function cos(d : ValReal) : ValReal;[internproc:fpc_in_cos_real];
{$endif}
{$define FPC_SYSTEM_HAS_EXP}
{$ifdef INTERNCONSTINTF}
function fpc_exp_real(d : ValReal) : ValReal;assembler;compilerproc;
{$else}
function exp(d : ValReal) : ValReal;assembler;[internconst:fpc_in_const_exp];
{$endif}
asm
// comes from DJ GPP
fldt d
fldl2e
fmulp %st,%st(1)
fstcw .LCW1
fstcw .LCW2
fwait
andw $0xf3ff,.LCW2
orw $0x0400,.LCW2
fldcw .LCW2
fld %st(0)
frndint
fldcw .LCW1
fxch %st(1)
fsub %st(1),%st
f2xm1
fld1
faddp %st,%st(1)
fscale
fstp %st(1)
fclex
jmp .LCW3
// store some help data in the data segment
.data
.LCW1:
.word 0
.LCW2:
.word 0
.text
.LCW3:
end;
{$define FPC_SYSTEM_HAS_FRAC}
{$ifdef INTERNCONSTINTF}
function fpc_frac_real(d : ValReal) : ValReal;assembler;compilerproc;
{$else}
function frac(d : ValReal) : ValReal;assembler;[internconst:fpc_in_const_frac];
{$endif}
asm
subl $16,%esp
fnstcw -4(%ebp)
fwait
movw -4(%ebp),%cx
orw $0x0f00,%cx
movw %cx,-8(%ebp)
fldcw -8(%ebp)
fldt d
frndint
fldt d
fsub %st(1),%st
fstp %st(1)
fldcw -4(%ebp)
end;
{$define FPC_SYSTEM_HAS_INT}
{$ifdef INTERNCONSTINTF}
function fpc_int_real(d : ValReal) : ValReal;assembler;compilerproc;
{$else}
function int(d : ValReal) : ValReal;assembler;[internconst:fpc_in_const_int];
{$endif}
asm
subl $16,%esp
fnstcw -4(%ebp)
fwait
movw -4(%ebp),%cx
orw $0x0f00,%cx
movw %cx,-8(%ebp)
fldcw -8(%ebp)
fwait
fldt d
frndint
fwait
fldcw -4(%ebp)
end;
{$define FPC_SYSTEM_HAS_TRUNC}
{$ifdef INTERNCONSTINTF}
function fpc_trunc_real(d : ValReal) : int64;assembler;compilerproc;
{$else}
function trunc(d : ValReal) : int64;assembler;[internconst:fpc_in_const_trunc];
{$endif}
var
oldcw,
newcw : word;
res : int64;
asm
fnstcw oldcw
fwait
movw oldcw,%cx
orw $0x0f00,%cx
movw %cx,newcw
fldcw newcw
fldt d
fistpq res
fwait
movl res,%eax
movl res+4,%edx
fldcw oldcw
end;
{$define FPC_SYSTEM_HAS_ROUND}
{$ifdef internconstintf}
function fpc_round_real(d : ValReal) : int64;assembler;compilerproc;
{$else}
{$ifdef hascompilerproc}
function round(d : ValReal) : int64;[internconst:fpc_in_const_round, external name 'FPC_ROUND'];
function fpc_round(d : ValReal) : int64;assembler;[public, alias:'FPC_ROUND'];{$ifdef hascompilerproc}compilerproc;{$endif hascompilerproc}
{$else}
function round(d : ValReal) : int64;assembler;[internconst:fpc_in_const_round];
{$endif hascompilerproc}
{$endif}
var
res : int64;
asm
fldt d
fistpq res
fwait
movl res,%eax
movl res+4,%edx
end;
{$define FPC_SYSTEM_HAS_POWER}
function power(bas,expo : ValReal) : ValReal;
begin
if bas=0 then
begin
if expo<>0 then
power:=0.0
else
HandleError(207);
end
else if expo=0 then
power:=1
else
{ bas < 0 is not allowed when doing roots }
if (bas<0) and (frac(expo) <> 0) then
handleerror(207)
else
begin
power:=exp(ln(abs(bas))*expo);
if (bas < 0) and
odd(trunc(expo)) then
begin
power := -power;
end;
end;
end;
{
$Log: math.inc,v $
Revision 1.24 2005/03/13 17:14:46 florian
* some floating point routines improved
Revision 1.23 2005/03/09 20:50:11 florian
* C. Western: utf-8 reading from resource files
Revision 1.22 2005/02/14 17:13:22 peter
* truncate log
}
|
