diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 1145346d92..a4c0013b15 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -194,8 +194,7 @@ unit-test [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail [ 2+1/2 -1 >base ] [ invalid-radix? ] must-fail-with -[ 123.456 8 >base ] [ invalid-radix? ] must-fail-with -[ 123.456 2 >base ] [ invalid-radix? ] must-fail-with +[ 123.456 7 >base ] [ invalid-radix? ] must-fail-with { "0/0." } [ 0.0 0.0 / number>string ] unit-test @@ -226,6 +225,26 @@ unit-test { "1.0p-1074" } [ 1 bits>double >hex ] unit-test { "-0.0" } [ -0.0 >hex ] unit-test +{ "1.0p0" } [ 1.0 >bin ] unit-test +{ "1.1p2" } [ 6.0 >bin ] unit-test +{ "1.00001p2" } [ 4.125 >bin ] unit-test +{ "1.1p-2" } [ 0.375 >bin ] unit-test +{ "-1.1p2" } [ -6.0 >bin ] unit-test +{ "1.1p10" } [ 1536.0 >bin ] unit-test +{ "0.0" } [ 0.0 >bin ] unit-test +{ "1.0p-1074" } [ 1 bits>double >bin ] unit-test +{ "-0.0" } [ -0.0 >bin ] unit-test + +{ "1.0p0" } [ 1.0 >oct ] unit-test +{ "1.4p2" } [ 6.0 >oct ] unit-test +{ "1.02p2" } [ 4.125 >oct ] unit-test +{ "1.4p-2" } [ 0.375 >oct ] unit-test +{ "-1.4p2" } [ -6.0 >oct ] unit-test +{ "1.4p10" } [ 1536.0 >oct ] unit-test +{ "0.0" } [ 0.0 >oct ] unit-test +{ "1.0p-1074" } [ 1 bits>double >oct ] unit-test +{ "-0.0" } [ -0.0 >oct ] unit-test + { 1.0 } [ "1.0p0" hex> ] unit-test { 1.5 } [ "1.8p0" hex> ] unit-test { 1.875 } [ "1.ep0" hex> ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 715f810e7e..bb8e220a0f 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -504,21 +504,38 @@ M: ratio >base [ -0.0 double>bits bitnot bitand -52 shift ] bi mantissa-expt-normalize ; -: float>hex-sign ( bits -- str ) +: bin-float-sign ( bits -- str ) -0.0 double>bits bitand zero? "" "-" ? ; -: float>hex-value ( mantissa -- str ) - >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail +: bin-float-value ( str size -- str' ) + CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail [ "0" ] when-empty "1." prepend ; -: float>hex-expt ( mantissa -- str ) +: float>hex-value ( mantissa -- str ) + >hex 13 bin-float-value ; + +: float>oct-value ( mantissa -- str ) + 4 * >oct 18 bin-float-value ; + +: float>bin-value ( mantissa -- str ) + >bin 52 bin-float-value ; + +: bin-float-expt ( mantissa -- str ) 10 >base "p" prepend ; -: float>hex ( n -- str ) +: (bin-float>base) ( value-quot n -- str ) double>bits - [ float>hex-sign ] [ - mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi* - ] bi 3append ; + [ bin-float-sign swap ] [ + mantissa-expt rot [ bin-float-expt ] bi* + ] bi 3append ; inline + +: bin-float>base ( n base -- str ) + { + { 16 [ [ float>hex-value ] swap (bin-float>base) ] } + { 8 [ [ float>oct-value ] swap (bin-float>base) ] } + { 2 [ [ float>bin-value ] swap (bin-float>base) ] } + [ invalid-radix ] + } case ; : format-string ( format -- format ) 0 suffix >byte-array ; foldable @@ -538,9 +555,8 @@ M: ratio >base : float>base ( n radix -- str ) { - { 16 [ float>hex ] } { 10 [ "%.16g" format-float ] } - [ invalid-radix ] + [ bin-float>base ] } case ; inline PRIVATE>