Fix /f for large integers

core/bootstrap/compiler/compiler.factor

@@ -18,6 +18,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
+: compile-uncompiled [ compiled? not ] filter compile ;
+
 nl
 "Compiling..." write flush
 
@@ -42,38 +44,38 @@ nl
     find-pair-next namestack*
 
     bitand bitor bitxor bitnot
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
-    + 1+ 1- 2/ < <= > >= shift min
-} compile
+    + 1+ 1- 2/ < <= > >= shift
+} compile-uncompiled
 
 "." write flush
 
 {
     new-sequence nth push pop peek
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     hashcode* = get set
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     . lines
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile
+} compile-uncompiled
 
-vocabs [ words [ compiled? not ] filter compile "." write flush ] each
+vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

core/math/floats/floats.factor

@@ -6,8 +6,6 @@ IN: math.floats.private
 M: fixnum >float fixnum>float ;
 M: bignum >float bignum>float ;
 
-M: float zero? dup 0.0 float= swap -0.0 float= or ;
-
 M: float >fixnum float>fixnum ;
 M: float >bignum float>bignum ;
 M: float >float ;
@@ -22,4 +20,7 @@ M: float + float+ ;
 M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
+M: float /f float/f ;
 M: float mod float-mod ;
+
+M: real abs dup 0 < [ neg ] when ;

core/math/integers/integers-tests.factor

@@ -191,3 +191,29 @@ unit-test
 [ f ] [ -128 power-of-2? ] unit-test
 [ f ] [ 0 power-of-2? ] unit-test
 [ t ] [ 1 power-of-2? ] unit-test
+
+[ 5. ] [ 5 1 ratio>float ] unit-test
+[ 4. ] [ 4 1 ratio>float ] unit-test
+[ 2. ] [ 2 1 ratio>float ] unit-test
+[ .5 ] [ 1 2 ratio>float ] unit-test
+[ .75 ] [ 3 4 ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 0.4 ] [ 6 15 ratio>float ] unit-test
+
+[ HEX: 3fe553522d230931 ]
+[ 61967020039 92984792073 ratio>float double>bits ] unit-test
+
+: random-integer
+    32 random-bits
+    1 random zero? [ neg ] when
+    1 random zero? [ >bignum ] when ;
+
+[ t ] [
+    1000 [
+        drop
+        random-integer
+        random-integer
+        [ >float / ] [ ratio>float ] 2bi 0.1 ~
+    ] all?
+] unit-test

core/math/integers/integers.factor

@@ -1,4 +1,5 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2008, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private sequences
 sequences.private math math.private combinators ;
@@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
 M: fixnum - fixnum- ;
 M: fixnum * fixnum* ;
 M: fixnum /i fixnum/i ;
+M: fixnum /f >r >float r> >float float/f ;
+
 M: fixnum mod fixnum-mod ;
 
 M: fixnum /mod fixnum/mod ;
@@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
 M: bignum bit? bignum-bit? ;
 M: bignum (log2) bignum-log2 ;
 
-M: integer zero? 0 number= ;
+! Converting ratios to floats. Based on FLOAT-RATIO from
+! sbcl/src/code/float.lisp, which has the following license:
+
+! "The software is in the public domain and is
+! provided with absolutely no warranty."
+
+! First step: pre-scaling
+: twos ( x -- y ) dup 1- bitxor log2 ; inline
+
+: scale-denonimator ( den -- scaled-den scale' )
+    dup twos neg [ shift ] keep ; inline
+
+: pre-scale ( num den -- scale shifted-num scaled-den )
+    2dup [ log2 ] bi@ -
+    tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
+    -rot ; inline
+
+! Second step: loop
+: shift-mantissa ( scale mantissa -- scale' mantissa' )
+    [ 1+ ] [ 2/ ] bi* ; inline
+
+: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
+    [ 2dup /i log2 53 > ]
+    [ >r shift-mantissa r> ]
+    [ ] while /mod ; inline
+
+! Third step: post-scaling
+: unscaled-float ( mantissa -- n )
+    52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+
+: scale-float ( scale mantissa -- float' )
+    >r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
+
+: post-scale ( scale mantissa -- n )
+    2/ dup log2 52 > [ shift-mantissa ] when
+    unscaled-float scale-float ; inline
+
+! Main word
+: /f-abs ( m n -- f )
+    over zero? [
+        2drop 0 >float
+    ] [
+        dup zero? [
+            2drop 1 >float 0 >float /
+        ] [
+            pre-scale
+            /f-loop over odd?
+            [ zero? [ 1+ ] unless ] [ drop ] if
+            post-scale
+        ] if
+    ] if ; inline
+
+M: bignum /f ( m n -- f )
+    [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;

core/math/math.factor

@@ -21,6 +21,7 @@ MATH: +   ( x y -- z ) foldable
 MATH: -   ( x y -- z ) foldable
 MATH: *   ( x y -- z ) foldable
 MATH: /   ( x y -- z ) foldable
+MATH: /f  ( x y -- z ) foldable
 MATH: /i  ( x y -- z ) foldable
 MATH: mod ( x y -- z ) foldable
 
@@ -33,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable
 GENERIC: bitnot ( x -- y ) foldable
 GENERIC# bit? 1 ( x n -- ? ) foldable
 
+GENERIC: abs ( x -- y ) foldable
+
 <PRIVATE
 
 GENERIC: (log2) ( x -- n ) foldable
@@ -46,10 +49,7 @@ PRIVATE>
         (log2)
     ] if ; foldable
 
-GENERIC: zero? ( x -- ? ) foldable
-
-M: object zero? drop f ;
-
+: zero? ( x -- ? ) 0 number= ; inline
 : 1+ ( x -- y ) 1 + ; inline
 : 1- ( x -- y ) 1 - ; inline
 : 2/ ( x -- y ) -1 shift ; inline
@@ -60,8 +60,6 @@ M: object zero? drop f ;
 
 : ?1+ [ 1+ ] [ 0 ] if* ; inline
 
-: /f  ( x y -- z ) >r >float r> >float float/f ; inline
-
 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
 
 : 2^ ( n -- 2^n ) 1 swap shift ; inline

extra/math/functions/functions.factor

@@ -80,10 +80,6 @@ M: integer (^)
         -rot (^mod)
     ] if ; foldable
 
-GENERIC: abs ( x -- y ) foldable
-
-M: real abs dup 0 < [ neg ] when ;
-
 GENERIC: absq ( x -- y ) foldable
 
 M: real absq sq ;

extra/math/ratios/ratios.factor

@@ -47,5 +47,6 @@ M: ratio - 2dup scale - -rot ratio+d / ;
 M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
+M: ratio /f scale /f ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;
 M: ratio /mod [ /i ] 2keep mod ;