diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index 87767181cd..3792d6ba9b 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -1,32 +1,40 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel math sequences prettyprint math.parser io +math.functions ; IN: math.floating-point -: float-sign ( float -- ? ) - float>bits -31 shift { 1 -1 } nth ; +: (double-sign) ( bits -- n ) -63 shift ; inline +: double-sign ( double -- n ) double>bits (double-sign) ; -: double-sign ( float -- ? ) - double>bits -63 shift { 1 -1 } nth ; - -: float-exponent-bits ( float -- n ) - float>bits -23 shift 8 2^ 1- bitand ; +: (double-exponent-bits) ( bits -- n ) + -52 shift 11 2^ 1- bitand ; inline : double-exponent-bits ( double -- n ) - double>bits -52 shift 11 2^ 1- bitand ; + double>bits (double-exponent-bits) ; -: float-mantissa-bits ( float -- n ) - float>bits 23 2^ 1- bitand ; +: (double-mantissa-bits) ( double -- n ) + 52 2^ 1- bitand ; : double-mantissa-bits ( double -- n ) - double>bits 52 2^ 1- bitand ; + double>bits (double-mantissa-bits) ; -: float-e ( -- float ) 127 ; inline -: double-e ( -- float ) 1023 ; inline +: >double ( S E M -- frac ) + [ 52 shift ] dip + [ 63 shift ] 2dip bitor bitor bits>double ; -! : calculate-float ( S M E -- float ) - ! float-e - 2^ * * ; ! bits>float ; +: >double< ( double -- S E M ) + double>bits + [ (double-sign) ] + [ (double-exponent-bits) ] + [ (double-mantissa-bits) ] tri ; -! : calculate-double ( S M E -- frac ) - ! double-e - 2^ swap 52 2^ /f 1+ * * ; +: double. ( double -- ) + double>bits + [ (double-sign) .b ] + [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ] + [ + (double-mantissa-bits) >bin 52 CHAR: 0 pad-left + 11 [ bl ] times print + ] tri ;