extra/math/floating-point/floating-point.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math sequences prettyprint math.parser io
   4 math.functions math.bitwise combinators.short-circuit ;
   5 IN: math.floating-point
   6
   7 : (double-sign) ( bits -- n ) -63 shift ; inline
   8 : double-sign ( double -- n ) double>bits (double-sign) ;
   9
  10 : (double-exponent-bits) ( bits -- n )
  11     -52 shift 11 on-bits mask ; inline
  12
  13 : double-exponent-bits ( double -- n )
  14     double>bits (double-exponent-bits) ;
  15
  16 : (double-mantissa-bits) ( double -- n )
  17     52 on-bits mask ;
  18
  19 : double-mantissa-bits ( double -- n )
  20     double>bits (double-mantissa-bits) ;
  21
  22 : >double ( S E M -- frac )
  23     [ 52 shift ] dip
  24     [ 63 shift ] 2dip bitor bitor bits>double ;
  25
  26 : >double< ( double -- S E M )
  27     double>bits
  28     [ (double-sign) ]
  29     [ (double-exponent-bits) ]
  30     [ (double-mantissa-bits) ] tri ;
  31
  32 : double. ( double -- )
  33     double>bits
  34     [ (double-sign) .b ]
  35     [ (double-exponent-bits) >bin 11 CHAR: 0 pad-head bl print ]
  36     [
  37         (double-mantissa-bits) >bin 52 CHAR: 0 pad-head
  38         11 [ bl ] times print
  39     ] tri ;
  40
  41 : infinity? ( double -- ? )
  42     double>bits
  43     {
  44         [ (double-exponent-bits) 11 on-bits = ]
  45         [ (double-mantissa-bits) 0 = ]
  46     } 1&& ;
  47
  48 : check-special ( n -- n )
  49     dup fp-special? [ "cannot be special" throw ] when ;
  50
  51 : double>ratio ( double -- a/b )
  52     check-special double>bits
  53     [ (double-sign) zero? 1 -1 ? ]
  54     [ (double-mantissa-bits) 52 2^ / ]
  55     [ (double-exponent-bits) ] tri
  56     [ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;