steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.integers: make bignum/f round to even on tie 

Fixes #372
db4
Joe Groff 2011-11-26 17:44:29 -08:00
parent 0f5b551790
commit 98fc1e28bd
1 changed files with 17 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
core/math/integers/integers.factor
View File

@ -110,14 +110,21 @@ M: bignum (log2) bignum-log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
: pre-scale ( num den -- mantissa den' scale )
: (epsilon?) ( num shift -- ? )
dup neg? [ neg 2^ 1 - bitand zero? not ] [ 2drop f ] if ; inline
: pre-scale ( num den -- epsilon? mantissa den' scale )
2dup [ log2 ] bi@ -
[ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi* ; inline
[ neg 54 + [ (epsilon?) ] [ shift ] 2bi ]
[ [ scale-denonimator ] dip + ] bi-curry bi* ; inline
! Second step: loop
: /f-loop ( mantissa den scale -- fraction-and-guard rem scale' )
: (2/-with-epsilon) ( epsilon? num -- epsilon?' num' )
[ 1 bitand zero? not or ] [ 2/ ] bi ; inline
: /f-loop ( epsilon? mantissa den scale -- epsilon?' fraction-and-guard rem scale' )
[ 2over /i log2 53 > ]
[ [ 2/ ] [ ] [ 1 + ] tri* ] while
[ [ (2/-with-epsilon) ] [ ] [ 1 + ] tri* ] while
[ /mod ] dip ; inline
! Third step: post-scaling
@ -132,9 +139,13 @@ M: bignum (log2) bignum-log2 ; inline
[ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when
scale-float ; inline
: round-to-nearest ( fraction-and-guard rem -- fraction-and-guard' )
: round-to-nearest ( epsilon? fraction-and-guard rem -- fraction-and-guard' )
over odd?
[ zero? [ dup zero? [ 1 + ] unless ] [ 1 + ] if ] [ drop ] if ;
[
zero? [
dup 2 bitand zero? not rot or [ 1 + ] when
] [ nip 1 + ] if
] [ drop nip ] if ;
inline
! Main word