math.floating-point: adding double>ratio.

diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor
index 2f13237c9d20469f4036f26f6d9f1cc30718d015..0bf09633a4db03e100837030f97e0e17adc5a3db 100644 (file)
--- a/extra/math/floating-point/floating-point-tests.factor
+++ b/extra/math/floating-point/floating-point-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test math.floating-point kernel
-math.constants fry sequences math ;
+math.constants fry sequences math random ;
 IN: math.floating-point.tests
 
 [ t ] [ pi >double< >double pi = ] unit-test
@@ -13,3 +13,19 @@ IN: math.floating-point.tests
 [ f ] [ 10. infinity? ] unit-test
 [ f ] [ -10. infinity? ] unit-test
 [ f ] [ 0. infinity? ] unit-test
+
+[ 0 ] [ 0.0 double>ratio ] unit-test
+[ 1 ] [ 1.0 double>ratio ] unit-test
+[ 1/2 ] [ 0.5 double>ratio ] unit-test
+[ 3/4 ] [ 0.75 double>ratio ] unit-test
+[ 12+1/2 ] [ 12.5 double>ratio ] unit-test
+[ -12-1/2 ] [ -12.5 double>ratio ] unit-test
+[ 3+39854788871587/281474976710656 ] [ pi double>ratio ] unit-test
+
+: roundtrip ( n -- )
+    [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
+
+{ 1 12 123 1234 } [ bits>double roundtrip ] each
+
+100 [ -10.0 10.0 uniform-random-float roundtrip ] times
+

diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor
index e6e92919e2014bb4afdad9554609e8e0245d066e..fb9b258038abca54f65095104f60efb1ba03b133 100644 (file)
--- a/extra/math/floating-point/floating-point.factor
+++ b/extra/math/floating-point/floating-point.factor
@@ -44,3 +44,14 @@ IN: math.floating-point
         [ (double-exponent-bits) 11 on-bits = ]
         [ (double-mantissa-bits) 0 = ]
     } 1&& ;
+
+: check-special ( n -- n )
+    dup fp-special? [ "cannot be special" throw ] when ;
+
+: double>ratio ( double -- a/b )
+    check-special double>bits
+    [ (double-sign) zero? 1 -1 ? ]
+    [ (double-mantissa-bits) 52 2^ / ]
+    [ (double-exponent-bits) ] tri
+    dup zero? [ 1 + ] [ [ 1 + ] dip ] if 1023 - 2 swap ^ * * ;
+