diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 160b220173..661bccd88c 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2006 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.private ; IN: math.floats.private @@ -28,3 +28,37 @@ M: float /i float/f >integer ; inline M: float mod float-mod ; inline M: real abs dup 0 < [ neg ] when ; inline + +M: float fp-special? + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline + +M: float fp-nan-payload + double>bits 52 2^ 1 - bitand ; inline + +M: float fp-nan? + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline + +M: float fp-qnan? + dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline + +M: float fp-snan? + dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline + +M: float fp-infinity? + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline + +M: float next-float ( m -- n ) + double>bits + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] if + ] if ; inline + +M: float prev-float ( m -- n ) + double>bits + dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative + dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero + 1 - bits>double ! positive non-zero + ] if + ] if ; inline diff --git a/core/math/math.factor b/core/math/math.factor index 1213e13a1f..e6c34c112c 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -97,55 +97,18 @@ GENERIC: fp-snan? ( x -- ? ) GENERIC: fp-infinity? ( x -- ? ) GENERIC: fp-nan-payload ( x -- bits ) -M: object fp-special? - drop f ; inline -M: object fp-nan? - drop f ; inline -M: object fp-qnan? - drop f ; inline -M: object fp-snan? - drop f ; inline -M: object fp-infinity? - drop f ; inline -M: object fp-nan-payload - drop f ; inline - -M: float fp-special? - double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline - -M: float fp-nan-payload - double>bits HEX: fffffffffffff bitand ; inline - -M: float fp-nan? - dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline - -M: float fp-qnan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline - -M: float fp-snan? - dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline - -M: float fp-infinity? - dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline +M: object fp-special? drop f ; inline +M: object fp-nan? drop f ; inline +M: object fp-qnan? drop f ; inline +M: object fp-snan? drop f ; inline +M: object fp-infinity? drop f ; inline +M: object fp-nan-payload drop f ; inline : ( payload -- nan ) HEX: 7ff0000000000000 bitor bits>double ; inline -: next-float ( m -- n ) - double>bits - dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero - dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero - 1 + bits>double ! positive - ] if - ] if ; inline - -: prev-float ( m -- n ) - double>bits - dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative - dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero - 1 - bits>double ! positive non-zero - ] if - ] if ; inline +GENERIC: next-float ( m -- n ) +GENERIC: prev-float ( m -- n ) : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline