core/math/floats/floats.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math math.order math.private ;
   4 IN: math.floats
   5
   6 <PRIVATE
   7 : float-unordered? ( x y -- ? ) [ fp-nan? ] either? ;
   8 : float-min ( x y -- z ) [ float< ] most ; foldable
   9 : float-max ( x y -- z ) [ float> ] most ; foldable
  10
  11 M: float >fixnum float>fixnum ; inline
  12 M: float >bignum float>bignum ; inline
  13 M: float >float ; inline
  14
  15 M: float hashcode* nip float>bits ; inline
  16 M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
  17 M: float number= float= ; inline
  18
  19 M: float <  float< ; inline
  20 M: float <= float<= ; inline
  21 M: float >  float> ; inline
  22 M: float >= float>= ; inline
  23
  24 M: float unordered? float-unordered? ; inline
  25 M: float u<  float-u< ; inline
  26 M: float u<= float-u<= ; inline
  27 M: float u>  float-u> ; inline
  28 M: float u>= float-u>= ; inline
  29
  30 M: float min over float? [ float-min ] [ call-next-method ] if ; inline
  31 M: float max over float? [ float-max ] [ call-next-method ] if ; inline
  32
  33 M: float + float+ ; inline
  34 M: float - float- ; inline
  35 M: float * float* ; inline
  36 M: float / float/f ; inline
  37 M: float /f float/f ; inline
  38 M: float /i float/f >integer ; inline
  39
  40 M: real abs dup 0 < [ neg ] when ; inline
  41
  42 M: real /mod 2dup mod [ swap [ - ] [ /i ] bi* ] keep ; inline
  43
  44 M: float fp-special?
  45     double>bits -52 shift 0x7ff [ bitand ] keep = ; inline
  46
  47 M: float fp-nan-payload
  48     double>bits 52 2^ 1 - bitand ; inline
  49
  50 M: float fp-nan?
  51     dup float= not ;
  52
  53 M: float fp-qnan?
  54     dup fp-nan? [ fp-nan-payload 51 bit? ] [ drop f ] if ; inline
  55
  56 M: float fp-snan?
  57     dup fp-nan? [ fp-nan-payload 51 bit? not ] [ drop f ] if ; inline
  58
  59 M: float fp-infinity?
  60     dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
  61
  62 M: float next-float
  63     double>bits
  64     dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
  65         dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
  66             1 + bits>double ! positive
  67         ] if
  68     ] if ; inline
  69
  70 M: float prev-float
  71     double>bits
  72     dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
  73         dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
  74             1 - bits>double ! positive non-zero
  75         ] if
  76     ] if ; inline
  77
  78 M: float fp-sign double>bits 63 bit? ; inline
  79
  80 M: float neg? fp-sign ; inline
  81
  82 M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline
  83
  84 PRIVATE>