fp-nan? was defined incorrectly. while i'm here, let's add some more float manipulation words

core/math/math-docs.factor

@@ -245,10 +245,22 @@ HELP: times
     { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
 } ;
 
+HELP: fp-special?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-nan?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
 
+HELP: fp-qnan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
+HELP: fp-snan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
 HELP: fp-infinity?
 { $values { "x" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
@@ -257,7 +269,26 @@ HELP: fp-infinity?
     { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
 } ;
 
-{ fp-nan? fp-infinity? } related-words
+HELP: fp-nan-payload
+{ $values { "x" real } { "bits" integer } }
+{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
+
+HELP: <fp-nan>
+{ $values { "payload" integer } { "float" float } }
+{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
+{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
+
+{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
+
+HELP: next-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+
+HELP: prev-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+
+{ next-float prev-float } related-words
 
 HELP: real-part
 { $values { "z" number } { "x" real } }

core/math/math-tests.factor

@@ -12,7 +12,24 @@ IN: math.tests
 [ f ] [ 1/0. fp-nan? ] unit-test
 [ f ] [ -1/0. fp-nan? ] unit-test
 [ t ] [ -0/0. fp-nan? ] unit-test
+[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
+! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
+! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
+[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
 
 [ t ] [ 1/0. fp-infinity? ] unit-test
 [ t ] [ -1/0. fp-infinity? ] unit-test
 [ f ] [ -0/0. fp-infinity? ] unit-test
+
+[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
+[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+
+[ 0.0 ] [ -0.0 next-float ] unit-test
+[ t ] [ 1.0 dup next-float < ] unit-test
+[ t ] [ -1.0 dup next-float < ] unit-test
+
+[ -0.0 ] [ 0.0 prev-float ] unit-test
+[ t ] [ 1.0 dup prev-float > ] unit-test
+[ t ] [ -1.0 dup prev-float > ] unit-test

core/math/math.factor

@@ -81,26 +81,62 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
 
 UNION: number real complex ;
 
+GENERIC: fp-special? ( x -- ? )
 GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
 
+M: object fp-special?
+    drop f ;
 M: object fp-nan?
     drop f ;
-
-M: float fp-nan?
-    double>bits -51 shift HEX: fff [ bitand ] keep = ;
-
-GENERIC: fp-infinity? ( x -- ? )
-
+M: object fp-qnan?
+    drop f ;
+M: object fp-snan?
+    drop f ;
 M: object fp-infinity?
     drop f ;
+M: object fp-nan-payload
+    drop f ;
 
-M: float fp-infinity? ( float -- ? )
+M: float fp-special?
+    double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+
+M: float fp-nan-payload
+    double>bits HEX: fffffffffffff bitand ; foldable flushable
+
+M: float fp-nan?
+    dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+
+M: float fp-qnan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+
+M: float fp-snan?
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+
+M: float fp-infinity?
+    dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+
+: <fp-nan> ( payload -- nan )
+    HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+
+: next-float ( m -- n )
     double>bits
-    dup -52 shift HEX: 7ff [ bitand ] keep = [
-        HEX: fffffffffffff bitand 0 =
-    ] [
-        drop f
-    ] if ;
+    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 ; foldable flushable
+
+: 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 ; foldable flushable
 
 : next-power-of-2 ( m -- n )
     dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline