math.floats: fix abs on floats; -0.0 abs should be 0.0 not -0.0

diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor
index de84346a580469534ebd867276677a5025c61e09..220eb339606ae36704964dbe30e16e66c99dcbb5 100644 (file)
--- 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 aa55e2d0eed6585a2dd78895bba17f317289e3f6..9c49e99231591965cd43442764deb762e46d918f 100644 (file)
--- 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 4fb39f93f76a2e39adf80057cf58959aed2cd55b..900c1e1ceee104383b9c951af68fe349ddf014c6 100755 (executable)
--- 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
 
 : <fp-nan> ( payload -- nan )
     HEX: 7ff0000000000000 bitor bits>double ; inline