[ 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
{ "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
[ -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
: float>base ( n radix -- str )
{
- { 16 [ float>hex ] }
{ 10 [ "%.16g" format-float ] }
- [ invalid-radix ]
+ [ bin-float>base ]
} case ; inline
PRIVATE>