From b11caac25fe126bce41d463951cd5cee9edd7e0e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 3 Dec 2008 19:15:58 -0600
Subject: [PATCH] add infinity? and nan? to math.floating-point

---
 .../floating-point/floating-point-tests.factor   | 12 +++++++++++-
 extra/math/floating-point/floating-point.factor  | 16 +++++++++++++++-
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor
index 7f3a87f9a5..129956331b 100644
--- a/extra/math/floating-point/floating-point-tests.factor
+++ b/extra/math/floating-point/floating-point-tests.factor
@@ -1,7 +1,17 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test math.floating-point math.constants kernel ;
+USING: tools.test math.floating-point math.constants kernel
+math.constants fry sequences kernel math ;
 IN: math.floating-point.tests
 
 [ t ] [ pi >double< >double pi = ] unit-test
 [ t ] [ -1.0 >double< >double -1.0 = ] unit-test
+
+[ t ] [ 1/0. infinity? ] unit-test
+[ t ] [ -1/0. infinity? ] unit-test
+[ f ] [ 0/0. infinity? ] unit-test
+[ f ] [ 10. infinity? ] unit-test
+[ f ] [ -10. infinity? ] unit-test
+[ f ] [ 0. infinity? ] unit-test
+
+[ t ] [ 0/0. nan? ] unit-test
diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor
index 0d224bfc9d..02fcd01e11 100644
--- a/extra/math/floating-point/floating-point.factor
+++ b/extra/math/floating-point/floating-point.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences prettyprint math.parser io
-math.functions math.bitwise ;
+math.functions math.bitwise combinators.short-circuit ;
 IN: math.floating-point
 
 : (double-sign) ( bits -- n ) -63 shift ; inline
@@ -37,3 +37,17 @@ IN: math.floating-point
         (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
         11 [ bl ] times print
     ] tri ;
+
+: nan? ( double -- ? )
+    double>bits
+    {
+        [ (double-exponent-bits) 11 on-bits = ]
+        [ (double-mantissa-bits) 0 > ]
+    } 1&& ;
+
+: infinity? ( double -- ? )
+    double>bits
+    {
+        [ (double-exponent-bits) 11 on-bits = ]
+        [ (double-mantissa-bits) 0 = ]
+    } 1&& ;