diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index de84346a58..220eb33960 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -67,3 +67,11 @@ unit-test [ t ] [ 0/0. 1.0 unordered? ] unit-test [ f ] [ 1.0 1.0 unordered? ] unit-test +[ t ] [ -0.0 fp-sign ] unit-test +[ t ] [ -1.0 fp-sign ] unit-test +[ f ] [ 0.0 fp-sign ] unit-test +[ f ] [ 1.0 fp-sign ] unit-test + +[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test +[ 1.5 ] [ -1.5 abs ] unit-test +[ 1.5 ] [ 1.5 abs ] unit-test diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index aa55e2d0ee..9c49e99231 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -50,7 +50,7 @@ M: float fp-snan? M: float fp-infinity? dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline -M: float next-float ( m -- n ) +M: float next-float double>bits dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero @@ -60,10 +60,14 @@ M: float next-float ( m -- n ) M: float unordered? [ fp-nan? ] bi@ or ; inline -M: float prev-float ( m -- n ) +M: float prev-float 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 + +M: float fp-sign double>bits 63 bit? ; inline + +M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline diff --git a/core/math/math.factor b/core/math/math.factor index 4fb39f93f7..900c1e1cee 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -99,13 +99,13 @@ GENERIC: fp-qnan? ( x -- ? ) GENERIC: fp-snan? ( x -- ? ) GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) +GENERIC: fp-sign ( x -- ? ) 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 : ( payload -- nan ) HEX: 7ff0000000000000 bitor bits>double ; inline