core/math/floats/floats.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.private ;
   4 IN: math.floats.private
   5
   6 M: fixnum >float fixnum>float ; inline
   7 M: bignum >float bignum>float ; inline
   8
   9 M: float >fixnum float>fixnum ; inline
  10 M: float >bignum float>bignum ; inline
  11 M: float >float ; inline
  12
  13 M: float hashcode* nip float>bits ; inline
  14 M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
  15 M: float number= float= ; inline
  16
  17 M: float < float< ; inline
  18 M: float <= float<= ; inline
  19 M: float > float> ; inline
  20 M: float >= float>= ; inline
  21
  22 M: float + float+ ; inline
  23 M: float - float- ; inline
  24 M: float * float* ; inline
  25 M: float / float/f ; inline
  26 M: float /f float/f ; inline
  27 M: float /i float/f >integer ; inline
  28 M: float mod float-mod ; inline
  29
  30 M: real abs dup 0 < [ neg ] when ; inline
  31
  32 M: float fp-special?
  33     double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
  34
  35 M: float fp-nan-payload
  36     double>bits 52 2^ 1 - bitand ; inline
  37
  38 M: float fp-nan?
  39     dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
  40
  41 M: float fp-qnan?
  42     dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
  43
  44 M: float fp-snan?
  45     dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline
  46
  47 M: float fp-infinity?
  48     dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
  49
  50 M: float next-float ( m -- n )
  51     double>bits
  52     dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
  53         dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
  54             1 + bits>double ! positive
  55         ] if
  56     ] if ; inline
  57
  58 M: float prev-float ( m -- n )
  59     double>bits
  60     dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
  61         dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
  62             1 - bits>double ! positive non-zero
  63         ] if
  64     ] if ; inline