mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-03 03:30:15 +02:00
+ cgenmath with libc math functions. Faster than the routines in genmath
and also have full double support (exp() only has support for values in
the single range in genmath, for example). Used in FPC_USE_LIBC is
defined
* several fixes to allow compilation with -dHASINLINE, but internalerrors
because of missing support for inlining assembler code
This commit is contained in:
Jonas Maebe
parent
bf57e41ac5
commit
0f26252376
@ -53,7 +53,7 @@ procedure FillByte (var x;count : longint;value : byte );{$ifdef SYSTEMINLINE}in
|
||||
begin
|
||||
if count <= 0 then
|
||||
exit;
|
||||
FillChar (X,Count,CHR(VALUE));
|
||||
FillChar (X,Count,value);
|
||||
end;
|
||||
{$endif not FPC_SYSTEM_HAS_FILLBYTE}
|
||||
|
||||
@ -140,7 +140,7 @@ end;
|
||||
|
||||
function libc_pchar_length(p:pchar):cardinal; cdecl; external 'c' name 'strlen';
|
||||
|
||||
function fpc_pchar_length(p:pchar):longint;[public,alias:'FPC_PCHAR_LENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif} {$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
function fpc_pchar_length(p:pchar):longint;[public,alias:'FPC_PCHAR_LENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
||||
begin
|
||||
fpc_pchar_length:=libc_pchar_length(p);
|
||||
end;
|
||||
@ -150,7 +150,15 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2004-05-01 15:26:33 jonas
|
||||
Revision 1.3 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.2 2004/05/01 15:26:33 jonas
|
||||
* use some more string routines from libc if FPC_USE_LIBC is used
|
||||
|
||||
Revision 1.1 2004/01/11 11:10:07 jonas
|
||||
|
||||
185
rtl/inc/cgenmath.inc
Normal file
185
rtl/inc/cgenmath.inc
Normal file
@ -0,0 +1,185 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2001 by Several contributors
|
||||
|
||||
Generic mathemtical routines in libc
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{ for 80x86, we can easily write the optimal inline code }
|
||||
{$ifndef cpui386}
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_INT}
|
||||
{$define FPC_SYSTEM_HAS_INT}
|
||||
|
||||
{$ifdef SUPPORT_DOUBLE}
|
||||
function c_trunc(d: double): double; cdecl; external 'c' name 'trunc';
|
||||
|
||||
function int(d: double): double; {$ifdef MATHINLINE}inline;{$endif} [internconst:in_const_int];
|
||||
begin
|
||||
result := c_trunc(d);
|
||||
end;
|
||||
|
||||
|
||||
{$else SUPPORT_DOUBLE}
|
||||
|
||||
function c_truncf(d: real): double; cdecl; external 'c' name 'truncf';
|
||||
|
||||
function int(d: real): real; {$ifdef MATHINLINE}inline; dsfqsdfqs{$endif}
|
||||
begin
|
||||
result := c_truncf(d);
|
||||
end;
|
||||
|
||||
function int(d: real) : real;[internconst:in_const_int];
|
||||
begin
|
||||
{ this will be correct since real = single in the case of }
|
||||
{ the motorola version of the compiler... }
|
||||
int:=c_truncf(d);
|
||||
end;
|
||||
{$endif SUPPORT_DOUBLE}
|
||||
|
||||
{$endif}
|
||||
|
||||
|
||||
{$ifndef SYSTEM_HAS_FREXP}
|
||||
{$define SYSTEM_HAS_FREXP}
|
||||
function c_frexp(x: double; var e: longint): double; cdecl; external 'c' name 'frexp';
|
||||
|
||||
function frexp(x:Real; var e:Integer ):Real; {$ifdef MATHINLINE}inline;{$endif}
|
||||
var
|
||||
l: longint;
|
||||
begin
|
||||
frexp := c_frexp(x,l);
|
||||
e := l;
|
||||
end;
|
||||
{$endif not SYSTEM_HAS_FREXP}
|
||||
|
||||
|
||||
{$ifndef SYSTEM_HAS_LDEXP}
|
||||
{$define SYSTEM_HAS_LDEXP}
|
||||
function c_ldexp(x: double; n: longint): double; cdecl; external 'c' name 'ldexp';
|
||||
|
||||
function ldexp( x: Real; N: Integer):Real;{$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
ldexp := c_ldexp(x,n);
|
||||
end;
|
||||
{$endif not SYSTEM_HAS_LDEXP}
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_SQRT}
|
||||
{$define FPC_SYSTEM_HAS_SQRT}
|
||||
|
||||
function c_sqrt(d: double): double; cdecl; external 'c' name 'sqrt';
|
||||
|
||||
function sqrt(d:Real):Real;[internconst:in_const_sqrt]; [public, alias: 'FPC_SQRT_REAL']; {$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
sqrt := c_sqrt(d);
|
||||
end;
|
||||
|
||||
{$ifdef hascompilerproc}
|
||||
function fpc_sqrt_real(d:Real):Real;compilerproc; external name 'FPC_SQRT_REAL';
|
||||
{$endif hascompilerproc}
|
||||
|
||||
{$endif}
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_EXP}
|
||||
{$define FPC_SYSTEM_HAS_EXP}
|
||||
function c_exp(d: double): double; cdecl; external 'c' name 'exp';
|
||||
|
||||
function Exp(d:Real):Real;[internconst:in_const_exp]; {$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
exp := c_exp(d);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_ROUND}
|
||||
{$define FPC_SYSTEM_HAS_ROUND}
|
||||
|
||||
function c_llround(d: double): int64; cdecl; external 'c' name 'llround';
|
||||
|
||||
{$ifdef hascompilerproc}
|
||||
function round(d : Real) : int64;[internconst:in_const_round, external name 'FPC_ROUND'];
|
||||
|
||||
function fpc_round(d : Real) : int64;[public, alias:'FPC_ROUND'];{$ifdef hascompilerproc}compilerproc;{$endif hascompilerproc}
|
||||
begin
|
||||
fpc_round := c_llround(d);
|
||||
end;
|
||||
{$else}
|
||||
function round(d : Real) : int64;[internconst:in_const_round];
|
||||
begin
|
||||
round := c_llround(d);
|
||||
end;
|
||||
{$endif hascompilerproc}
|
||||
{$endif}
|
||||
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_LN}
|
||||
{$define FPC_SYSTEM_HAS_LN}
|
||||
|
||||
function c_log(d: double): double; cdecl; external 'c' name 'log';
|
||||
|
||||
function Ln(d:Real):Real;[internconst:in_const_ln];{$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
ln := c_log(d);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_SIN}
|
||||
{$define FPC_SYSTEM_HAS_SIN}
|
||||
function c_sin(d: double): double; cdecl; external 'c' name 'sin';
|
||||
|
||||
function Sin(d:Real):Real;[internconst:in_const_sin]; {$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
sin := c_sin(d);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_COS}
|
||||
{$define FPC_SYSTEM_HAS_COS}
|
||||
function c_cos(d: double): double; cdecl; external 'c' name 'cos';
|
||||
|
||||
function Cos(d:Real):Real;[internconst:in_const_cos]; {$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
cos := c_cos(d);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_ARCTAN}
|
||||
{$define FPC_SYSTEM_HAS_ARCTAN}
|
||||
function c_atan(d: double): double; cdecl; external 'c' name 'atan';
|
||||
|
||||
function ArcTan(d:Real):Real;[internconst:in_const_arctan]; {$ifdef MATHINLINE}inline;{$endif}
|
||||
begin
|
||||
arctan := c_atan(d);
|
||||
end;
|
||||
{$endif}
|
||||
|
||||
{$endif not i386}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
}
|
||||
@ -1216,7 +1216,7 @@ end;
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_SYSRESETFPU}
|
||||
|
||||
procedure SysResetFpu;
|
||||
procedure SysResetFpu;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
begin
|
||||
{ nothing todo }
|
||||
end;
|
||||
@ -1225,7 +1225,15 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.80 2004-07-18 20:21:44 florian
|
||||
Revision 1.81 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.80 2004/07/18 20:21:44 florian
|
||||
+ several unicode (to/from utf-8 conversion) stuff added
|
||||
* some longint -> SizeInt changes
|
||||
|
||||
|
||||
@ -415,6 +415,7 @@ type
|
||||
{$endif not FPC_SYSTEM_HAS_ABS}
|
||||
|
||||
|
||||
{$ifndef SYSTEM_HAS_FREXP}
|
||||
function frexp(x:Real; var e:Integer ):Real;
|
||||
{* frexp() extracts the exponent from x. It returns an integer *}
|
||||
{* power of two to expnt and the significand between 0.5 and 1 *}
|
||||
@ -435,8 +436,10 @@ type
|
||||
end;
|
||||
frexp := x;
|
||||
end;
|
||||
{$endif not SYSTEM_HAS_FREXP}
|
||||
|
||||
|
||||
{$ifndef SYSTEM_HAS_LDEXP}
|
||||
function ldexp( x: Real; N: Integer):Real;
|
||||
{* ldexp() multiplies x by 2**n. *}
|
||||
var r : Real;
|
||||
@ -456,6 +459,7 @@ type
|
||||
end;
|
||||
ldexp := x * R;
|
||||
end;
|
||||
{$endif not SYSTEM_HAS_LDEXP}
|
||||
|
||||
|
||||
function polevl(var x:Real; var Coef:TabCoef; N:Integer):Real;
|
||||
@ -1244,7 +1248,15 @@ function fpc_int64_to_double(i : int64): double; compilerproc;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.26 2004-10-03 14:09:39 florian
|
||||
Revision 1.27 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.26 2004/10/03 14:09:39 florian
|
||||
* fixed trunc for abs(value) < 1
|
||||
|
||||
Revision 1.25 2004/10/03 14:00:21 florian
|
||||
|
||||
@ -33,18 +33,26 @@
|
||||
|
||||
{ declarations of the math routines }
|
||||
|
||||
{$ifndef cpui386}
|
||||
{$ifdef FPC_USE_LIBC}
|
||||
{$ifdef SYSTEMINLINE}
|
||||
{$define MATHINLINE}
|
||||
{$endif}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
function abs(d : extended) : extended;
|
||||
function arctan(d : extended) : extended;
|
||||
function cos(d : extended) : extended;
|
||||
function exp(d : extended) : extended;
|
||||
function arctan(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function cos(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function exp(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function frac(d : extended) : extended;
|
||||
function int(d : extended) : extended;
|
||||
function ln(d : extended) : extended;
|
||||
function int(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function ln(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function pi : extended;
|
||||
function round(d : extended) : int64;
|
||||
function sin(d : extended) : extended;
|
||||
function sin(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function sqr(d : extended) : extended;
|
||||
function sqrt(d : extended) : extended;
|
||||
function sqrt(d : extended) : extended;{$ifdef MATHINLINE}inline;{$endif}
|
||||
function trunc(d : extended) : int64;
|
||||
function power(bas,expo : extended) : extended;
|
||||
function power(bas,expo : int64) : int64;
|
||||
@ -70,7 +78,15 @@
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.15 2004-02-08 15:33:50 florian
|
||||
Revision 1.16 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.15 2004/02/08 15:33:50 florian
|
||||
* linking problems fixed
|
||||
+ abi tag added
|
||||
|
||||
|
||||
@ -234,6 +234,10 @@ begin
|
||||
end;
|
||||
{$endif SUPPORT_EXTENDED}
|
||||
|
||||
{$ifdef FPC_USE_LIBC}
|
||||
{ Include libc versions }
|
||||
{$i cgenmath.inc}
|
||||
{$endif FPC_USE_LIBC}
|
||||
{ Include processor specific routines }
|
||||
{$I math.inc}
|
||||
{ Include generic version }
|
||||
@ -887,7 +891,15 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.64 2004-09-03 19:26:01 olle
|
||||
Revision 1.65 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.64 2004/09/03 19:26:01 olle
|
||||
+ added maxExitCode to all System.pp
|
||||
* constrained error code to be below maxExitCode in RunError et. al.
|
||||
|
||||
|
||||
@ -371,24 +371,30 @@ Var
|
||||
Processor specific routines
|
||||
****************************************************************************}
|
||||
|
||||
Procedure Move(const source;var dest;count:SizeInt);
|
||||
{$ifdef FPC_USE_LIBC}
|
||||
{$ifdef SYSTEMINLINE}
|
||||
{$define INLINEGENERICS}
|
||||
{$endif}
|
||||
{$endif}
|
||||
|
||||
Procedure Move(const source;var dest;count:SizeInt);{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
Procedure FillChar(Var x;count:SizeInt;Value:Boolean);{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
Procedure FillChar(Var x;count:SizeInt;Value:Char);{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
Procedure FillChar(Var x;count:SizeInt;Value:Byte);
|
||||
procedure FillByte(var x;count:SizeInt;value:byte);
|
||||
Procedure FillChar(Var x;count:SizeInt;Value:Byte);{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
procedure FillByte(var x;count:SizeInt;value:byte);{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
Procedure FillWord(Var x;count:SizeInt;Value:Word);
|
||||
procedure FillDWord(var x;count:SizeInt;value:DWord);
|
||||
function IndexChar(const buf;len:SizeInt;b:char):SizeInt;
|
||||
function IndexByte(const buf;len:SizeInt;b:byte):SizeInt;
|
||||
function IndexByte(const buf;len:SizeInt;b:byte):SizeInt;{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
function Indexword(const buf;len:SizeInt;b:word):SizeInt;
|
||||
function IndexDWord(const buf;len:SizeInt;b:DWord):SizeInt;
|
||||
function CompareChar(const buf1,buf2;len:SizeInt):SizeInt;
|
||||
function CompareByte(const buf1,buf2;len:SizeInt):SizeInt;
|
||||
function CompareByte(const buf1,buf2;len:SizeInt):SizeInt;{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
function CompareWord(const buf1,buf2;len:SizeInt):SizeInt;
|
||||
function CompareDWord(const buf1,buf2;len:SizeInt):SizeInt;
|
||||
procedure MoveChar0(const buf1;var buf2;len:SizeInt);
|
||||
function IndexChar0(const buf;len:SizeInt;b:char):SizeInt;
|
||||
function CompareChar0(const buf1,buf2;len:SizeInt):SizeInt;
|
||||
function CompareChar0(const buf1,buf2;len:SizeInt):SizeInt;{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
procedure prefetch(const mem);
|
||||
|
||||
|
||||
@ -453,7 +459,7 @@ Function Sseg:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
****************************************************************************}
|
||||
|
||||
function strpas(p:pchar):shortstring;
|
||||
function strlen(p:pchar):longint;
|
||||
function strlen(p:pchar):longint;{$ifdef INLINEGENERICS}inline;{$endif}
|
||||
|
||||
{ Shortstring functions }
|
||||
{$ifndef INTERNSETLENGTH}
|
||||
@ -755,7 +761,15 @@ const
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.102 2004-09-22 05:56:11 hajny
|
||||
Revision 1.103 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.102 2004/09/22 05:56:11 hajny
|
||||
* compilation fix
|
||||
|
||||
Revision 1.101 2004/09/21 23:43:26 hajny
|
||||
|
||||
@ -35,38 +35,11 @@ const
|
||||
{$define FPC_SYSTEM_HAS_SQR}
|
||||
function sqr(d : extended) : extended;[internproc:in_sqr_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;
|
||||
|
||||
}
|
||||
|
||||
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 trunc(d : extended) : int64;assembler;[internconst:in_const_trunc];
|
||||
{ input: d in fr1 }
|
||||
@ -154,8 +127,10 @@ const
|
||||
subfze r3,r3
|
||||
.LTruncPositive:
|
||||
end;
|
||||
{$endif not FPC_SYSTEM_HAS_TRUNC}
|
||||
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_ROUND}
|
||||
{$define FPC_SYSTEM_HAS_ROUND}
|
||||
{$ifdef hascompilerproc}
|
||||
function round(d : extended) : int64;[internconst:in_const_round, external name 'FPC_ROUND'];
|
||||
@ -250,92 +225,7 @@ const
|
||||
subfze r3,r3
|
||||
.LRoundPositive:
|
||||
end;
|
||||
|
||||
|
||||
{$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;
|
||||
{$endif not FPC_SYSTEM_HAS_ROUND}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
@ -426,7 +316,15 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.33 2004-02-09 20:21:06 olle
|
||||
Revision 1.34 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.33 2004/02/09 20:21:06 olle
|
||||
* fixed global variable access in asm
|
||||
|
||||
Revision 1.32 2003/12/07 19:55:37 jonas
|
||||
|
||||
@ -1030,7 +1030,7 @@ function fpc_pchar_length(p:pchar):longint;assembler;[public,alias:'FPC_PCHAR_LE
|
||||
|
||||
|
||||
{$define FPC_SYSTEM_HAS_GET_FRAME}
|
||||
function get_frame:pointer;assembler;
|
||||
function get_frame:pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
{ all abi's I know use r1 as stack pointer }
|
||||
mr r3, r1
|
||||
@ -1038,7 +1038,7 @@ end;
|
||||
|
||||
|
||||
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
|
||||
function get_caller_addr(framebp:pointer):pointer;assembler;
|
||||
function get_caller_addr(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
cmplwi r3,0
|
||||
beq .Lcaller_addr_frame_null
|
||||
@ -1055,7 +1055,7 @@ end;
|
||||
|
||||
|
||||
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
|
||||
function get_caller_frame(framebp:pointer):pointer;assembler;
|
||||
function get_caller_frame(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
cmplwi r3,0
|
||||
beq .Lcaller_frame_null
|
||||
@ -1064,7 +1064,7 @@ asm
|
||||
end;
|
||||
|
||||
{$define FPC_SYSTEM_HAS_ABS_LONGINT}
|
||||
function abs(l:longint):longint; assembler;[internconst:in_const_abs];
|
||||
function abs(l:longint):longint; assembler;[internconst:in_const_abs];{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
srawi r0,r3,31
|
||||
add r3,r0,r3
|
||||
@ -1077,21 +1077,21 @@ end;
|
||||
****************************************************************************}
|
||||
|
||||
{$define FPC_SYSTEM_HAS_ODD_LONGINT}
|
||||
function odd(l:longint):boolean;assembler;[internconst:in_const_odd];
|
||||
function odd(l:longint):boolean;assembler;[internconst:in_const_odd];{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
rlwinm r3,r3,0,31,31
|
||||
end;
|
||||
|
||||
|
||||
{$define FPC_SYSTEM_HAS_SQR_LONGINT}
|
||||
function sqr(l:longint):longint;assembler;[internconst:in_const_sqr];
|
||||
function sqr(l:longint):longint;assembler;[internconst:in_const_sqr];{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
mullw r3,r3,r3
|
||||
end;
|
||||
|
||||
|
||||
{$define FPC_SYSTEM_HAS_SPTR}
|
||||
Function Sptr : Pointer;assembler;
|
||||
Function Sptr : Pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif}
|
||||
asm
|
||||
mr r3,r1
|
||||
end;
|
||||
@ -1137,7 +1137,15 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.67 2004-05-01 17:02:37 jonas
|
||||
Revision 1.68 2004-10-09 21:00:46 jonas
|
||||
+ cgenmath with libc math functions. Faster than the routines in genmath
|
||||
and also have full double support (exp() only has support for values in
|
||||
the single range in genmath, for example). Used in FPC_USE_LIBC is
|
||||
defined
|
||||
* several fixes to allow compilation with -dHASINLINE, but internalerrors
|
||||
because of missing support for inlining assembler code
|
||||
|
||||
Revision 1.67 2004/05/01 17:02:37 jonas
|
||||
* use some more string routines from libc if FPC_USE_LIBC is used
|
||||
|
||||
Revision 1.66 2004/04/29 20:00:47 peter
|
||||
|
||||
Loading…
Reference in New Issue
Block a user