use radix literals

[factor.git] / core / math / integers / integers.factor

diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index 4dd948021aa2ad1f0996e67883f42abb6a5e75d8..3cab1dd4e83c06adb12d466555e3eb4def6c1bdd 100644 (file)
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -14,6 +14,7 @@ M: integer denominator drop 1 ; inline
 M: fixnum >fixnum ; inline
 M: fixnum >bignum fixnum>bignum ; inline
 M: fixnum >integer ; inline
+M: fixnum >float fixnum>float ; inline
 
 M: fixnum hashcode* nip ; inline
 M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
@@ -37,16 +38,6 @@ M: fixnum - fixnum- ; inline
 M: fixnum * fixnum* ; inline
 M: fixnum /i fixnum/i ; inline
 
-DEFER: bignum/f
-CONSTANT: bignum/f-threshold HEX: 20,0000,0000,0000
-
-: fixnum/f ( m n -- m/n )
-    [ >float ] bi@ float/f ; inline
-
-M: fixnum /f
-    2dup [ abs bignum/f-threshold >= ] either?
-    [ bignum/f ] [ fixnum/f ] if ; inline
-
 M: fixnum mod fixnum-mod ; inline
 
 M: fixnum /mod fixnum/mod ; inline
@@ -130,33 +121,49 @@ M: bignum (log2) bignum-log2 ; inline
     [ /mod ] dip ; inline
 
 ! Third step: post-scaling
-: unscaled-float ( mantissa -- n )
-    52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
-
 : scale-float ( mantissa scale -- float' )
-    dup 0 < [ neg 2^ recip ] [ 2^ ] if * ; inline
+    {
+        { [ dup 1024 > ] [ 2drop 1/0. ] }
+        { [ dup -1023 < ] [ 1021 + shift bits>double ] }
+        [ [ 52 2^ 1 - bitand ] dip 1022 + 52 shift bitor bits>double ]
+    } cond ; inline
 
 : post-scale ( mantissa scale -- n )
     [ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when
-    [ unscaled-float ] dip scale-float ; inline
+    scale-float ; inline
+
+: round-to-nearest ( fraction-and-guard rem -- fraction-and-guard' )
+    over odd?
+    [ zero? [ dup zero? [ 1 + ] unless ] [ 1 + ] if ] [ drop ] if ;
+    inline
 
 ! Main word
 : /f-abs ( m n -- f )
-    over zero? [
-        2drop 0.0
-    ] [
-        [
-            drop 1/0.
-        ] [
+    over zero? [ nip zero? 0/0. 0.0 ? ] [
+        [ drop 1/0. ] [
             pre-scale
             /f-loop
-            [ over odd? [ zero? [ 1 + ] unless ] [ drop ] if ] dip
+            [ round-to-nearest ] dip
             post-scale
         ] if-zero
     ] if ; inline
 
 : bignum/f ( m n -- f )
-    [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;
+    [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; inline
+
+M: bignum /f ( m n -- f ) { bignum bignum } declare bignum/f ;
+
+CONSTANT: bignum/f-threshold 0x20,0000,0000,0000
+
+: fixnum/f ( m n -- m/n )
+    [ >float ] bi@ float/f ; inline
+
+M: fixnum /f
+    { fixnum fixnum } declare
+    2dup [ abs bignum/f-threshold >= ] either?
+    [ bignum/f ] [ fixnum/f ] if ; inline
+
+: bignum>float ( bignum -- float )
+    { bignum } declare 1 >bignum bignum/f ;
 
-M: bignum /f ( m n -- f )
-    bignum/f ;
+M: bignum >float bignum>float ; inline