mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-08 12:57:27 +01:00
277 lines
7.9 KiB
PHP
277 lines
7.9 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2000 by Jonas Maebe and other members of the
|
|
Free Pascal development team
|
|
|
|
Implementation of mathamatical Routines (only for real)
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************
|
|
Int to real helpers
|
|
****************************************************************************}
|
|
|
|
const
|
|
longint_to_real_helper: int64 = $4330000080000000;
|
|
cardinal_to_real_helper: int64 = $430000000000000;
|
|
int_to_real_factor: double = double(high(cardinal))+1.0;
|
|
|
|
|
|
{****************************************************************************
|
|
EXTENDED data type routines
|
|
****************************************************************************}
|
|
|
|
{$define FPC_SYSTEM_HAS_PI}
|
|
function pi : double;[internproc:in_pi];
|
|
|
|
{$define FPC_SYSTEM_HAS_ABS}
|
|
function abs(d : extended) : extended;[internproc:in_abs_extended];
|
|
|
|
{$define FPC_SYSTEM_HAS_SQR}
|
|
function sqr(d : extended) : extended;[internproc:in_sqr_extended];
|
|
|
|
{$define FPC_SYSTEM_HAS_SQRT}
|
|
function sqrt(d : extended) : extended;[internproc:in_sqrt_extended];
|
|
|
|
{
|
|
function arctan(d : extended) : extended;[internconst:in_arctan_extended];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
function ln(d : extended) : extended;[internconst:in_ln_extended];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
function sin(d : extended) : extended;[internconst: in_sin_extended];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
function cos(d : extended) : extended;[internconst:in_cos_extended];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
function exp(d : extended) : extended;[internconst:in_const_exp];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
|
|
function frac(d : extended) : extended;[internconst:in_const_frac];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
|
|
}
|
|
{$define FPC_SYSTEM_HAS_INT}
|
|
{$warning FIX ME}
|
|
function int(d : extended) : extended;[internconst:in_const_int];
|
|
begin
|
|
runerror(207);
|
|
end;
|
|
|
|
|
|
{$define FPC_SYSTEM_HAS_TRUNC}
|
|
{$warning FIX ME}
|
|
function trunc(d : extended) : int64;{assembler;}[internconst:in_const_trunc];
|
|
{ input: d in fr1 }
|
|
{ output: result in r3 }
|
|
{assembler;}
|
|
var
|
|
temp: packed record
|
|
case byte of
|
|
0: (l1,l2: longint);
|
|
1: (d: double);
|
|
end;
|
|
begin{asm}
|
|
{ fctiwz f1,f1
|
|
stfd f1,temp
|
|
lwz r3,temp
|
|
lwz r4,4+temp}
|
|
end{ ['R3','F1']};
|
|
|
|
|
|
{$define FPC_SYSTEM_HAS_ROUND}
|
|
{$ifdef hascompilerproc}
|
|
function round(d : extended) : int64;[internconst:in_const_round, external name 'FPC_ROUND'];
|
|
|
|
function fpc_round(d : extended) : int64;[public, alias:'FPC_ROUND'];{$ifdef hascompilerproc}compilerproc;{$endif hascompilerproc}
|
|
{$else}
|
|
function round(d : extended) : int64;[internconst:in_const_round];
|
|
{$endif hascompilerproc}
|
|
{ input: d in fr1 }
|
|
{ output: result in r3 }
|
|
{assembler;}
|
|
var
|
|
temp : packed record
|
|
case byte of
|
|
0: (l1,l2: longint);
|
|
1: (d: double);
|
|
end;
|
|
begin{asm}
|
|
{ fctiw f1,f1
|
|
stfd f1,temp
|
|
lwz r3,temp
|
|
lwz r4,4+temp}
|
|
end{ ['R3','F1']};
|
|
|
|
|
|
{$define FPC_SYSTEM_HAS_POWER}
|
|
function power(bas,expo : extended) : extended;
|
|
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 }
|
|
if bas<0 then
|
|
handleerror(207)
|
|
else
|
|
power:=exp(ln(bas)*expo);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
Longint data type routines
|
|
****************************************************************************}
|
|
{$define FPC_SYSTEM_HAS_POWER_INT64}
|
|
function power(bas,expo : Int64) : Int64;
|
|
begin
|
|
if bas=0 then
|
|
begin
|
|
if expo<>0 then
|
|
power:=0
|
|
else
|
|
HandleError(207);
|
|
end
|
|
else if expo=0 then
|
|
power:=1
|
|
else
|
|
begin
|
|
if bas<0 then
|
|
begin
|
|
if odd(expo) then
|
|
power:=-round(exp(ln(-bas)*expo))
|
|
else
|
|
power:=round(exp(ln(-bas)*expo));
|
|
end
|
|
else
|
|
power:=round(exp(ln(bas)*expo));
|
|
end;
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Helper routines to support old TP styled reals
|
|
****************************************************************************}
|
|
|
|
{ warning: the following converts a little-endian TP-style real }
|
|
{ to a big-endian double. So don't byte-swap the TP real! }
|
|
{$define FPC_SYSTEM_HAS_REAL2DOUBLE}
|
|
function real2double(r : real48) : double;
|
|
|
|
var
|
|
res : array[0..7] of byte;
|
|
exponent : word;
|
|
|
|
begin
|
|
{ copy mantissa }
|
|
res[6]:=0;
|
|
res[5]:=r[1] shl 5;
|
|
res[4]:=(r[1] shr 3) or (r[2] shl 5);
|
|
res[3]:=(r[2] shr 3) or (r[3] shl 5);
|
|
res[2]:=(r[3] shr 3) or (r[4] shl 5);
|
|
res[1]:=(r[4] shr 3) or (r[5] and $7f) shl 5;
|
|
res[0]:=(r[5] and $7f) shr 3;
|
|
|
|
{ copy exponent }
|
|
{ correct exponent: }
|
|
exponent:=(word(r[0])+(1023-129));
|
|
res[1]:=res[1] or ((exponent and $f) shl 4);
|
|
res[0]:=exponent shr 4;
|
|
|
|
{ set sign }
|
|
res[0]:=res[0] or (r[5] and $80);
|
|
real2double:=double(res);
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.7 2003-09-14 15:02:24 peter
|
|
* remove int64 to double helpers
|
|
|
|
Revision 1.6 2003/09/02 17:41:49 peter
|
|
* updated for int64 to double
|
|
|
|
Revision 1.5 2003/09/01 20:46:32 peter
|
|
* new dummies
|
|
|
|
Revision 1.4 2003/04/23 21:28:21 peter
|
|
* fpc_round added, needed for int64 currency
|
|
|
|
Revision 1.3 2003/01/22 20:45:15 mazen
|
|
* making math code in RTL compiling.
|
|
*NB : This does NOT mean necessary that it will generate correct code!
|
|
|
|
Revision 1.2 2003/01/20 22:21:36 mazen
|
|
* many stuff related to RTL fixed
|
|
|
|
Revision 1.1 2002/12/24 21:30:20 mazen
|
|
- some writeln(s) removed in compiler
|
|
+ many files added to RTL
|
|
* some errors fixed in RTL
|
|
|
|
Revision 1.14 2002/11/28 11:04:16 olle
|
|
* macos: refs to globals in begin{asm} adapted to macos
|
|
|
|
Revision 1.13 2002/10/21 18:08:28 jonas
|
|
* round has int64 instead of longint result
|
|
|
|
Revision 1.12 2002/09/08 13:00:21 jonas
|
|
* made pi an internproc instead of internconst
|
|
|
|
Revision 1.11 2002/09/07 16:01:26 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
Revision 1.10 2002/08/18 22:11:10 florian
|
|
* fixed remaining assembler errors
|
|
|
|
Revision 1.9 2002/08/18 21:37:48 florian
|
|
* several errors in inline assembler fixed
|
|
|
|
Revision 1.8 2002/08/10 17:14:36 jonas
|
|
* various fixes, mostly changing the names of the modifies registers to
|
|
upper case since that seems to be required by the compiler
|
|
|
|
Revision 1.7 2002/07/31 16:58:12 jonas
|
|
* fixed conversion from int64/qword to double errors
|
|
|
|
Revision 1.6 2002/07/29 21:28:17 florian
|
|
* several fixes to get further with linux/ppc system unit compilation
|
|
|
|
Revision 1.5 2002/07/28 21:39:29 florian
|
|
* made abs a compiler proc if it is generic
|
|
|
|
Revision 1.4 2002/07/28 20:43:49 florian
|
|
* several fixes for linux/powerpc
|
|
* several fixes to MT
|
|
|
|
}
|