steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math: move float methods to math.floats

db4
Slava Pestov 2009-08-20 03:55:19 -05:00
parent a3631f1878
commit 79cdc45339
2 changed files with 43 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
core/math/floats/floats.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.private ;
IN: math.floats.private
@ -28,3 +28,37 @@ M: float /i float/f >integer ; inline
M: float mod float-mod ; inline
M: real abs dup 0 < [ neg ] when ; inline
M: float fp-special?
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
M: float fp-nan-payload
double>bits 52 2^ 1 - bitand ; inline
M: float fp-nan?
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
M: float fp-qnan?
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
M: float fp-snan?
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline
M: float fp-infinity?
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
M: float next-float ( m -- n )
double>bits
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
1 + bits>double ! positive
] if
] if ; inline
M: float prev-float ( m -- n )
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero
] if
] if ; inline

53
core/math/math.factor
View File

@ -97,55 +97,18 @@ GENERIC: fp-snan? ( x -- ? )
GENERIC: fp-infinity? ( x -- ? )
GENERIC: fp-nan-payload ( x -- bits )
M: object fp-special?
drop f ; inline
M: object fp-nan?
drop f ; inline
M: object fp-qnan?
drop f ; inline
M: object fp-snan?
drop f ; inline
M: object fp-infinity?
drop f ; inline
M: object fp-nan-payload
drop f ; inline
M: float fp-special?
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
M: float fp-nan-payload
double>bits HEX: fffffffffffff bitand ; inline
M: float fp-nan?
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
M: float fp-qnan?
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
M: float fp-snan?
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
M: float fp-infinity?
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
M: object fp-special? drop f ; inline
M: object fp-nan? drop f ; inline
M: object fp-qnan? drop f ; inline
M: object fp-snan? drop f ; inline
M: object fp-infinity? drop f ; inline
M: object fp-nan-payload drop f ; inline
: <fp-nan> ( payload -- nan )
HEX: 7ff0000000000000 bitor bits>double ; inline
: next-float ( m -- n )
double>bits
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
1 + bits>double ! positive
] if
] if ; inline
: prev-float ( m -- n )
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero
] if
] if ; inline
GENERIC: next-float ( m -- n )
GENERIC: prev-float ( m -- n )
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline