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

math.functions: fix truncate and round to output -0.0 for negative floats near 0

modern-harvey2
Jon Harper 2017-02-25 15:34:38 +01:00 committed by John Benediktsson
parent 271c7d9519
commit c74cfe6c54
2 changed files with 12 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/math/functions/functions-tests.factor
View File

@ -159,6 +159,11 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
{ -5.0 } [ -4.5 floor ] unit-test { -5.0 } [ -4.5 floor ] unit-test
{ -4.0 } [ -4.5 ceiling ] unit-test { -4.0 } [ -4.5 ceiling ] unit-test
{ t } [ -0.3 truncate double>bits -0.0 double>bits = ] unit-test
{ t } [ -0.3 ceiling double>bits -0.0 double>bits = ] unit-test
{ t } [ 0.3 floor double>bits 0.0 double>bits = ] unit-test
{ t } [ 0.3 truncate double>bits 0.0 double>bits = ] unit-test
{ -4.0 } [ -4.0 truncate ] unit-test { -4.0 } [ -4.0 truncate ] unit-test
{ -4.0 } [ -4.0 floor ] unit-test { -4.0 } [ -4.0 floor ] unit-test
{ -4.0 } [ -4.0 ceiling ] unit-test { -4.0 } [ -4.0 ceiling ] unit-test
@ -180,6 +185,9 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
{ 1 } [ 1/2 round ] unit-test { 1 } [ 1/2 round ] unit-test
{ 1 } [ 3/5 round ] unit-test { 1 } [ 3/5 round ] unit-test
{ t } [ -0.3 round double>bits -0.0 double>bits = ] unit-test
{ t } [ 0.3 round double>bits 0.0 double>bits = ] unit-test
{ 6 59967 } [ 3837888 factor-2s ] unit-test { 6 59967 } [ 3837888 factor-2s ] unit-test
{ 6 -59967 } [ -3837888 factor-2s ] unit-test { 6 -59967 } [ -3837888 factor-2s ] unit-test

5
basis/math/functions/functions.factor
View File

@ -348,7 +348,10 @@ M: real atan >float atan ; inline
: acot ( x -- y ) recip atan ; inline : acot ( x -- y ) recip atan ; inline
: truncate ( x -- y ) dup 1 mod - ; inline : truncate ( x -- y ) dup dup 1 mod - over float? [
over [ -1.0 > ] [ 0.0 < ] bi and
[ swap copysign ] [ nip ] if
] [ nip ] if ; inline
GENERIC: round ( x -- y ) GENERIC: round ( x -- y )