mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 17:31:42 +01:00
404 lines
12 KiB
PHP
404 lines
12 KiB
PHP
{
|
|
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 mathematical 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.
|
|
|
|
**********************************************************************}
|
|
|
|
|
|
const
|
|
longint_to_real_helper: int64 = $4330000080000000;
|
|
cardinal_to_real_helper: int64 = $4330000000000000;
|
|
int_to_real_factor: double = double(high(cardinal))+1.0;
|
|
|
|
|
|
{****************************************************************************
|
|
EXTENDED data type routines
|
|
****************************************************************************}
|
|
|
|
{$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;
|
|
|
|
const
|
|
factor: double = double(int64(1) shl 32);
|
|
factor2: double = double(int64(1) shl 31);
|
|
|
|
{$ifndef FPC_SYSTEM_HAS_TRUNC}
|
|
{$define FPC_SYSTEM_HAS_TRUNC}
|
|
function fpc_trunc_real(d : valreal) : int64;assembler;compilerproc;
|
|
{ input: d in fr1 }
|
|
{ output: result in r3 }
|
|
assembler;
|
|
var
|
|
temp: packed record
|
|
case byte of
|
|
0: (l1,l2: longint);
|
|
1: (d: double);
|
|
end;
|
|
asm
|
|
// store d in temp
|
|
stfd f1,temp
|
|
// extract sign bit (record in cr0)
|
|
lwz r3,temp
|
|
rlwinm. r3,r3,1,31,31
|
|
// make d positive
|
|
fabs f1,f1
|
|
// load 2^32 in f2
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
mflr r0
|
|
bcl 20,31,.Lpiclab
|
|
.Lpiclab:
|
|
mflr r5
|
|
mtlr r0
|
|
addis r4,r5,(factor-.Lpiclab)@ha
|
|
lfd f2,(factor-.Lpiclab)@l(r4)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r4,factor@ha
|
|
lfd f2,factor@l(r4)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r4,factor(r2)
|
|
lfd f2,0(r4)
|
|
{$endif not macos/aix}
|
|
// check if value is < 0
|
|
// f3 := d / 2^32;
|
|
fdiv f3,f1,f2
|
|
// round
|
|
fctiwz f4,f3
|
|
// store
|
|
stfd f4,temp
|
|
// and load into r4
|
|
lwz r3,temp+4
|
|
// convert back to float
|
|
lis r0,0x4330
|
|
stw r0,temp
|
|
xoris r0,r3,0x8000
|
|
stw r0,temp+4
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
addis r4,r5,(longint_to_real_helper-.Lpiclab)@ha
|
|
lfd f0,(longint_to_real_helper-.Lpiclab)@l(r4)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r4,longint_to_real_helper@ha
|
|
lfd f0,longint_to_real_helper@l(r4)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r4,longint_to_real_helper(r2)
|
|
lfd f0,0(r4)
|
|
{$endif not macos/aix}
|
|
lfd f3,temp
|
|
fsub f3,f3,f0
|
|
|
|
|
|
// f4 := d "mod" 2^32 ( = d - ((d / 2^32) * 2^32))
|
|
fnmsub f4,f3,f2,f1
|
|
|
|
// now, convert to unsigned 32 bit
|
|
|
|
// load 2^31 in f2
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
addis r4,r5,(factor2-.Lpiclab)@ha
|
|
lfd f2,(factor2-.Lpiclab)@l(r4)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r4,factor2@ha
|
|
lfd f2,factor2@l(r4)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r4,factor2(r2)
|
|
lfd f2,0(r4)
|
|
{$endif not macos/aix}
|
|
|
|
// subtract 2^31
|
|
fsub f3,f4,f2
|
|
// was the value > 2^31?
|
|
fcmpu cr1,f4,f2
|
|
// use diff if >= 2^31
|
|
fsel f4,f3,f3,f4
|
|
|
|
// next part same as conversion to signed integer word
|
|
fctiwz f4,f4
|
|
stfd f4,temp
|
|
lwz r4,temp+4
|
|
// add 2^31 if value was >=2^31
|
|
blt cr1, .LTruncNoAdd
|
|
xoris r4,r4,0x8000
|
|
.LTruncNoAdd:
|
|
// negate value if it was negative to start with
|
|
beq cr0,.LTruncPositive
|
|
subfic r4,r4,0
|
|
subfze r3,r3
|
|
.LTruncPositive:
|
|
end;
|
|
{$endif not FPC_SYSTEM_HAS_TRUNC}
|
|
|
|
|
|
(*
|
|
{$ifndef FPC_SYSTEM_HAS_ROUND}
|
|
{$define FPC_SYSTEM_HAS_ROUND}
|
|
function round(d : extended) : int64;
|
|
|
|
function fpc_round(d : extended) : int64;assembler;[public, alias:'FPC_ROUND'];compilerproc;
|
|
{ exactly the same as trunc, except that one fctiwz has become fctiw }
|
|
{ input: d in fr1 }
|
|
{ output: result in r3 }
|
|
assembler;
|
|
var
|
|
temp: packed record
|
|
case byte of
|
|
0: (l1,l2: longint);
|
|
1: (d: double);
|
|
end;
|
|
asm
|
|
// store d in temp
|
|
stfd f1, temp
|
|
// extract sign bit (record in cr0)
|
|
lwz r4,temp
|
|
rlwinm. r4,r4,1,31,31
|
|
// make d positive
|
|
fabs f1,f1
|
|
// load 2^32 in f2
|
|
{$if not defined(macos) and not defined(aix)}
|
|
lis r4,factor@ha
|
|
lfd f2,factor@l(r4)
|
|
{$else}
|
|
lwz r4,factor(r2)
|
|
lfd f2,0(r4)
|
|
{$endif}
|
|
// check if value is < 0
|
|
// f3 := d / 2^32;
|
|
fdiv f3,f1,f2
|
|
// round
|
|
fctiwz f4,f3
|
|
// store
|
|
stfd f4,temp
|
|
// and load into r4
|
|
lwz r3,temp+4
|
|
// convert back to float
|
|
lis r0,0x4330
|
|
stw r0,temp
|
|
xoris r0,r3,0x8000
|
|
stw r0,temp+4
|
|
{$if not defined(macos) and not defined(aix)}
|
|
lis r4,longint_to_real_helper@ha
|
|
lfd f0,longint_to_real_helper@l(r4)
|
|
{$else}
|
|
lwz r4,longint_to_real_helper(r2)
|
|
lfd f0,0(r4)
|
|
{$endif}
|
|
lfd f3,temp
|
|
fsub f3,f3,f0
|
|
|
|
|
|
// f4 := d "mod" 2^32 ( = d - ((d / 2^32) * 2^32))
|
|
fnmsub f4,f3,f2,f1
|
|
|
|
// now, convert to unsigned 32 bit
|
|
|
|
// load 2^31 in f2
|
|
{$if not defined(macos) and not defined(aix)}
|
|
lis r4,factor2@ha
|
|
lfd f2,factor2@l(r4)
|
|
{$else}
|
|
lwz r4,factor2(r2)
|
|
lfd f2,0(r4)
|
|
{$endif}
|
|
|
|
// subtract 2^31
|
|
fsub f3,f4,f2
|
|
// was the value > 2^31?
|
|
fcmpu cr1,f4,f2
|
|
// use diff if >= 2^31
|
|
fsel f4,f3,f3,f4
|
|
|
|
// next part same as conversion to signed integer word
|
|
fctiw f4,f4
|
|
stfd f4,temp
|
|
lwz r4,temp+4
|
|
// add 2^31 if value was >=2^31
|
|
blt cr1, .LRoundNoAdd
|
|
xoris r4,r4,0x8000
|
|
.LRoundNoAdd:
|
|
// negate value if it was negative to start with
|
|
beq cr0,.LRoundPositive
|
|
subfic r4,r4,0
|
|
subfze r3,r3
|
|
.LRoundPositive:
|
|
end;
|
|
{$endif not FPC_SYSTEM_HAS_ROUND}
|
|
*)
|
|
|
|
|
|
{****************************************************************************
|
|
Int to real helpers
|
|
****************************************************************************}
|
|
{$ifndef aix}
|
|
{ these helpers somehow don't seem to work on AIX/Power 7 }
|
|
|
|
{$define FPC_SYSTEM_HAS_INT64_TO_DOUBLE}
|
|
function fpc_int64_to_double(i: int64): double; compilerproc;
|
|
assembler;
|
|
{ input: high(i) in r4, low(i) in r3 }
|
|
{ output: double(i) in f0 }
|
|
var
|
|
temp: packed record
|
|
case byte of
|
|
0: (l1,l2: cardinal);
|
|
1: (d: double);
|
|
end;
|
|
asm
|
|
lis r0,0x4330
|
|
stw r0,temp
|
|
xoris r3,r3,0x8000
|
|
stw r3,temp+4
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
mflr r0
|
|
bcl 20,31,.Lpiclab
|
|
.Lpiclab:
|
|
mflr r5
|
|
mtlr r0
|
|
addis r3,r5,(longint_to_real_helper-.Lpiclab)@ha
|
|
lfd f1,(longint_to_real_helper-.Lpiclab)@l(r3)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r3,longint_to_real_helper@ha
|
|
lfd f1,longint_to_real_helper@l(r3)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r3,longint_to_real_helper(r2)
|
|
lfd f1,0(r3)
|
|
{$endif not mac os}
|
|
lfd f0,temp
|
|
stw r4,temp+4
|
|
fsub f0,f0,f1
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
addis r4,r5,(cardinal_to_real_helper-.Lpiclab)@ha
|
|
lfd f1,(cardinal_to_real_helper-.Lpiclab)@l(r4)
|
|
addis r4,r5,(int_to_real_factor-.Lpiclab)@ha
|
|
lfd f3,temp
|
|
lfd f2,(int_to_real_factor-.Lpiclab)@l(r4)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r4,cardinal_to_real_helper@ha
|
|
lfd f1,cardinal_to_real_helper@l(r4)
|
|
lis r4,int_to_real_factor@ha
|
|
lfd f3,temp
|
|
lfd f2,int_to_real_factor@l(r4)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r4,cardinal_to_real_helper(r2)
|
|
lwz r3,int_to_real_factor(r2)
|
|
lfd f3,temp
|
|
lfd f1,0(r4)
|
|
lfd f2,0(r3)
|
|
{$endif not macos/aix}
|
|
fsub f3,f3,f1
|
|
fmadd f1,f0,f2,f3
|
|
end;
|
|
|
|
|
|
{$define FPC_SYSTEM_HAS_QWORD_TO_DOUBLE}
|
|
function fpc_qword_to_double(q: qword): double; compilerproc;
|
|
assembler;
|
|
{ input: high(q) in r4, low(q) in r3 }
|
|
{ output: double(q) in f0 }
|
|
var
|
|
temp: packed record
|
|
case byte of
|
|
0: (l1,l2: cardinal);
|
|
1: (d: double);
|
|
end;
|
|
asm
|
|
lis r0,0x4330
|
|
stw r0,temp
|
|
stw r3,temp+4
|
|
lfd f0,temp
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
mflr r0
|
|
bcl 20,31,.Lpiclab
|
|
.Lpiclab:
|
|
mflr r5
|
|
mtlr r0
|
|
addis r3,r5,(cardinal_to_real_helper-.Lpiclab)@ha
|
|
lfd f1,(cardinal_to_real_helper-.Lpiclab)@l(r3)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r3,cardinal_to_real_helper@ha
|
|
lfd f1,cardinal_to_real_helper@l(r3)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r3,longint_to_real_helper(r2)
|
|
lfd f1,0(r3)
|
|
{$endif not macos/aix}
|
|
stw r4,temp+4
|
|
fsub f0,f0,f1
|
|
lfd f3,temp
|
|
{$if not defined(macos) and not defined(aix)}
|
|
{$ifdef FPC_PIC}
|
|
{$ifdef darwin}
|
|
addis r4,r5,(int_to_real_factor-.Lpiclab)@ha
|
|
lfd f2,(int_to_real_factor-.Lpiclab)@l(r4)
|
|
{$else darwin}
|
|
{$error Add pic code for linux/ppc32}
|
|
{$endif darwin}
|
|
{$else FPC_PIC}
|
|
lis r4,int_to_real_factor@ha
|
|
lfd f2,int_to_real_factor@l(r4)
|
|
{$endif FPC_PIC}
|
|
{$else not macos/aix}
|
|
lwz r4,int_to_real_factor(r2)
|
|
lfd f2,0(r4)
|
|
{$endif not macos/aix}
|
|
fsub f3,f3,f1
|
|
fmadd f1,f0,f2,f3
|
|
end;
|
|
{$endif}
|
|
|