math.parser: support >bin and >oct for floats

This is for symmetry with "0o1p0", "0b1p0", bin> and hex> which
all already work

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

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>