/core/math/floats/floats.factor

http://github.com/abeaumont/factor · Factor · 79 lines · 58 code · 19 blank · 2 comment · 16 complexity · c27c85299c28b77c13e08898cb8922aa MD5 · raw file

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