diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index b8b65d1334..f2ccb78a06 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math math.parser sequences tools.test ; +USING: kernel literals math math.parser sequences tools.test ; IN: math.parser.tests [ f ] @@ -126,3 +126,26 @@ unit-test [ "-3/4" ] [ -3/4 number>string ] unit-test [ "-1-1/4" ] [ -5/4 number>string ] unit-test + +[ "1.0p0" ] [ 1.0 >hex ] unit-test +[ "1.8p2" ] [ 6.0 >hex ] unit-test +[ "1.8p-2" ] [ 0.375 >hex ] unit-test +[ "-1.8p2" ] [ -6.0 >hex ] unit-test +[ "1.8p10" ] [ 1536.0 >hex ] unit-test +[ "0.0" ] [ 0.0 >hex ] unit-test +[ "1.0p-1074" ] [ 1 bits>double >hex ] unit-test +[ "-0.0" ] [ -0.0 >hex ] unit-test + +[ 1.0 ] [ "1.0" hex> ] unit-test +[ 15.5 ] [ "f.8" hex> ] unit-test +[ 15.53125 ] [ "f.88" hex> ] unit-test +[ -15.5 ] [ "-f.8" hex> ] unit-test +[ 15.5 ] [ "f.8p0" hex> ] unit-test +[ -15.5 ] [ "-f.8p0" hex> ] unit-test +[ 62.0 ] [ "f.8p2" hex> ] unit-test +[ 3.875 ] [ "f.8p-2" hex> ] unit-test +[ $[ 1 bits>double ] ] [ "1.0p-1074" hex> ] unit-test +[ 0.0 ] [ "1.0p-1075" hex> ] unit-test +[ 1/0. ] [ "1.0p1024" hex> ] unit-test +[ -1/0. ] [ "-1.0p1024" hex> ] unit-test + diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 9f07a7d953..8e911453ad 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -82,10 +82,38 @@ SYMBOL: negative? string>natural ] if ; inline -: string>float ( str -- n/f ) +: dec>float ( str -- n/f ) [ CHAR: , eq? not ] filter >byte-array 0 suffix (string>float) ; +: hex>float-parts ( str -- neg? mantissa-str expt ) + "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; + +: make-mantissa ( str -- bits ) + 16 base> dup log2 52 swap - shift ; + +: combine-hex-float-parts ( neg? mantissa expt -- float ) + dup 2046 > [ 2drop -1/0. 1/0. ? ] [ + dup 0 <= [ 1 - shift 0 ] when + [ HEX: 8000,0000,0000,0000 0 ? ] + [ 52 2^ 1 - bitand ] + [ 52 shift ] tri* bitor bitor + bits>double + ] if ; + +: hex>float ( str -- n/f ) + hex>float-parts + [ "." split1 [ append make-mantissa ] [ drop 16 base> log2 ] 2bi ] + [ + 1023 + ] bi* + combine-hex-float-parts ; + +: base>float ( str base -- n/f ) + { + { 10 [ dec>float ] } + { 16 [ hex>float ] } + [ "Floats can only be converted from strings in base 10 or 16" throw ] + } case ; + : number-char? ( char -- ? ) "0123456789ABCDEFabcdef." member? ; @@ -99,11 +127,14 @@ SYMBOL: negative? PRIVATE> +: string>float ( str -- n/f ) + 10 base>float ; + : base> ( str radix -- n/f ) over numeric-looking? [ over [ "/." member? ] find nip { { CHAR: / [ string>ratio ] } - { CHAR: . [ drop string>float ] } + { CHAR: . [ base>float ] } [ drop string>integer ] } case ] [ 2drop f ] if ; @@ -167,18 +198,58 @@ M: ratio >base [ ".0" append ] } cond ; -: float>string ( n -- str ) +bits bitnot bitand -52 shift ] bi + mantissa-expt-normalize ; + +: float>hex-sign ( bits -- str ) + -0.0 double>bits bitand zero? "" "-" ? ; + +: float>hex-value ( mantissa -- str ) + 16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ; + +: float>hex-expt ( mantissa -- str ) + 10 >base "p" prepend ; + +: float>hex ( n -- str ) + double>bits + [ float>hex-sign ] [ + mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi* + ] bi 3append ; + +: float>decimal ( n -- str ) (float>string) [ 0 = ] trim-tail >string fix-float ; +: float>base ( n base -- str ) + { + { 10 [ float>decimal ] } + { 16 [ float>hex ] } + [ "Floats can only be converted to strings in base 10 or 16" throw ] + } case ; + +PRIVATE> + +: float>string ( n -- str ) + 10 float>base ; + M: float >base - drop { - { [ dup fp-nan? ] [ drop "0/0." ] } - { [ dup 1/0. = ] [ drop "1/0." ] } - { [ dup -1/0. = ] [ drop "-1/0." ] } - { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } - [ float>string ] + { + { [ over fp-nan? ] [ 2drop "0/0." ] } + { [ over 1/0. = ] [ 2drop "1/0." ] } + { [ over -1/0. = ] [ 2drop "-1/0." ] } + { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] } + { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] } + [ float>base ] } cond ; : number>string ( n -- str ) 10 >base ;