/core/math/floats/floats.factor

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