add fp-infinity?, docs, and tests

core/math/math-docs.factor

@@ -301,6 +301,16 @@ 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-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 } "." }
+{ $examples
+    { $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" }
+    { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" }
+} ;
+
+{ fp-nan? fp-infinity? } related-words
+
 HELP: real-part
 { $values { "z" number } { "x" real } }
 { $description "Outputs the real part of a complex number. This acts as the identity on real numbers." }

core/math/math-tests.factor

@@ -9,3 +9,10 @@ IN: math.tests
 [ [ 0 1 2 3 4 ] ] [ [ 5 [ , ] each-integer ] [ ] make ] unit-test
 [ [ ] ] [ [ -1 [ , ] each-integer ] [ ] make ] unit-test
 
+[ f ] [ 1/0. fp-nan? ] unit-test
+[ f ] [ -1/0. fp-nan? ] unit-test
+[ t ] [ -0/0. fp-nan? ] unit-test
+
+[ t ] [ 1/0. fp-infinity? ] unit-test
+[ t ] [ -1/0. fp-infinity? ] unit-test
+[ f ] [ -0/0. fp-infinity? ] unit-test

core/math/math.factor

@@ -88,8 +88,20 @@ M: object fp-nan?
     drop f ;
 
 M: float fp-nan?
-    double>bits -51 shift BIN: 111111111111 [ bitand ] keep
-    number= ;
+    double>bits -51 shift HEX: fff [ bitand ] keep = ;
+
+GENERIC: fp-infinity? ( x -- ? )
+
+M: object fp-infinity?
+    drop f ;
+
+M: float fp-infinity? ( float -- ? )
+    double>bits
+    dup -52 shift HEX: 7ff [ bitand ] keep = [
+        HEX: fffffffffffff bitand 0 =
+    ] [
+        drop f
+    ] if ;
 
 : (next-power-of-2) ( i n -- n )
     2dup >= [