: emit-float-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline
-: emit-float-comparison ( cc -- )
+: emit-float-ordered-comparison ( cc -- )
+ [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+
+: emit-float-unordered-comparison ( cc -- )
[ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
: emit-float>fixnum ( -- )
{ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
- { math.private:float< [ drop cc< emit-float-comparison ] }
- { math.private:float<= [ drop cc<= emit-float-comparison ] }
- { math.private:float>= [ drop cc>= emit-float-comparison ] }
- { math.private:float> [ drop cc> emit-float-comparison ] }
- { math.private:float= [ drop cc= emit-float-comparison ] }
+ { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
+ { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
+ { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
+ { math.private:float> [ drop cc> emit-float-ordered-comparison ] }
+ { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
+ { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
+ { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
+ { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
+ { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
{ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
{ alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
+
+[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test
+
+[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.intervals assocs combinators ;
IN: compiler.tree.comparisons
! Some utilities for working with comparison operations.
-CONSTANT: comparison-ops { < > <= >= }
+CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= }
CONSTANT: generic-comparison-ops { before? after? before=? after=? }
: assumption ( i1 i2 op -- i3 )
{
- { \ < [ assume< ] }
- { \ > [ assume> ] }
- { \ <= [ assume<= ] }
- { \ >= [ assume>= ] }
+ { \ < [ assume< ] }
+ { \ > [ assume> ] }
+ { \ <= [ assume<= ] }
+ { \ >= [ assume>= ] }
+ { \ u< [ assume< ] }
+ { \ u> [ assume> ] }
+ { \ u<= [ assume<= ] }
+ { \ u>= [ assume>= ] }
} case ;
: interval-comparison ( i1 i2 op -- result )
{
- { \ < [ interval< ] }
- { \ > [ interval> ] }
- { \ <= [ interval<= ] }
- { \ >= [ interval>= ] }
+ { \ < [ interval< ] }
+ { \ > [ interval> ] }
+ { \ <= [ interval<= ] }
+ { \ >= [ interval>= ] }
+ { \ u< [ interval< ] }
+ { \ u> [ interval> ] }
+ { \ u<= [ interval<= ] }
+ { \ u>= [ interval>= ] }
} case ;
: swap-comparison ( op -- op' )
{ > < }
{ <= >= }
{ >= <= }
+ { u< u> }
+ { u> u< }
+ { u<= u>= }
+ { u>= u<= }
} at ;
: negate-comparison ( op -- op' )
{ > <= }
{ <= > }
{ >= < }
+ { u< u>= }
+ { u> u<= }
+ { u<= u> }
+ { u>= u< }
} at ;
: specific-comparison ( op -- op' )
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
-{ /f < > <= >= }
+{ /f < > <= >= u< u> u<= u>= }
[ { real real } "input-classes" set-word-prop ] each
{ /i mod /mod }
\ bitnot { integer } "input-classes" set-word-prop
-: real-op ( info quot -- quot' )
- [
- dup class>> real classes-intersect?
- [ clone ] [ drop real <class-info> ] if
- ] dip
- change-interval ; inline
-
-{ bitnot fixnum-bitnot bignum-bitnot } [
- [ [ interval-bitnot ] real-op ] "outputs" set-word-prop
-] each
-
-\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
-
-\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
-
: math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
: fits-in-fixnum? ( interval -- ? )
fixnum-interval interval-subset? ;
-: binary-op-class ( info1 info2 -- newclass )
- [ class>> ] bi@
- 2dup [ null-class? ] either? [ 2drop null ] [
- [ math-closure ] bi@ math-class-max
- ] if ;
-
-: binary-op-interval ( info1 info2 quot -- newinterval )
- [ [ interval>> ] bi@ ] dip call ; inline
-
: won't-overflow? ( class interval -- ? )
[ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
[ drop float ] dip
] unless ;
+: unary-op-class ( info -- newclass )
+ class>> dup null-class? [ drop null ] [ math-closure ] if ;
+
+: unary-op-interval ( info quot -- newinterval )
+ [ interval>> ] dip call ; inline
+
+: unary-op ( word interval-quot post-proc-quot -- )
+ '[
+ [ unary-op-class ] [ _ unary-op-interval ] bi
+ @
+ <class/interval-info>
+ ] "outputs" set-word-prop ;
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+ [ interval-bitnot ] [ integer-valued ] unary-op
+] each
+
+\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
+
+\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
+
+: binary-op-class ( info1 info2 -- newclass )
+ [ class>> ] bi@
+ 2dup [ null-class? ] either? [ 2drop null ] [
+ [ math-closure ] bi@ math-class-max
+ ] if ;
+
+: binary-op-interval ( info1 info2 quot -- newinterval )
+ [ [ interval>> ] bi@ ] dip call ; inline
+
: binary-op ( word interval-quot post-proc-quot -- )
'[
[ binary-op-class ] [ _ binary-op-interval ] 2bi
[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
+[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test
+
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
! Test type propagation for math ops
[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
+[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test
+
+[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
] final-literals
] unit-test
+[ V{ 1.5 } ] [
+ [
+ /f
+ dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+ ] final-literals
+] unit-test
+
[ V{ 1.5 } ] [
[
/f
] final-literals
] unit-test
+[ V{ 1.5 } ] [
+ [
+ /f
+ dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+ ] final-literals
+] unit-test
+
[ V{ f } ] [
[
/f
] final-literals
] unit-test
+[ V{ f } ] [
+ [
+ /f
+ dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+ ] final-literals
+] unit-test
+
[ V{ fixnum } ] [
[ 0 dup 10 > [ 100 * ] when ] final-classes
] unit-test
[ 0 dup 10 > [ drop "foo" ] when ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ 0 dup 10 u> [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare 3 3 - + ] final-classes
] unit-test
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
] unit-test
+[ V{ t } ] [
+ [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
+] unit-test
+
[ V{ "d" } ] [
[
3 {
[ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
[ V{ -1 } ] [
[ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
+[ V{ -1 } ] [
+ [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
+] unit-test
+
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
[ 0 * 10 < ] final-classes
] unit-test
+[ V{ object } ] [
+ [ 0 * 10 u< ] final-classes
+] unit-test
+
[ V{ 27 } ] [
[
123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
] final-literals
] unit-test
+[ V{ 27 } ] [
+ [
+ 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
+ ] final-literals
+] unit-test
+
[ V{ 27 } ] [
[
dup number? over sequence? and [
USING: kernel math math.floats.env math.floats.env.private
-math.functions math.libm sequences tools.test ;
+math.functions math.libm sequences tools.test locals
+compiler.units kernel.private fry compiler math.private words ;
IN: math.floats.env.tests
: set-default-fp-env ( -- )
! In case the tests screw up the FP env because of bugs in math.floats.env
set-default-fp-env
-[ t ] [
- [ 1.0 0.0 / drop ] collect-fp-exceptions
- +fp-zero-divide+ swap member?
-] unit-test
-
-[ t ] [
- [ 1.0 3.0 / drop ] collect-fp-exceptions
- +fp-inexact+ swap member?
-] unit-test
-
-[ t ] [
- [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
- +fp-overflow+ swap member?
-] unit-test
-
-[ t ] [
- [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions
- +fp-underflow+ swap member?
-] unit-test
-
-[ t ] [
- [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
- +fp-overflow+ swap member?
-] unit-test
-
-[ t ] [
- [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
- +fp-underflow+ swap member?
-] unit-test
-
-[ t ] [
- [ 0.0 0.0 /f drop ] collect-fp-exceptions
- +fp-invalid-operation+ swap member?
-] unit-test
-
-[ t ] [
- [ -1.0 fsqrt drop ] collect-fp-exceptions
- +fp-invalid-operation+ swap member?
-] unit-test
+: test-fp-exception ( exception inputs quot -- quot' )
+ '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
+
+: test-fp-exception-compiled ( exception inputs quot -- quot' )
+ '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
+
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test
+[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test
+
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
[
HEX: 3fd5,5555,5555,5555
-1.0 3.0 /f double>bits
] unit-test
-[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail
-[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail
-[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail
-[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail
-[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail
+: test-traps ( traps inputs quot -- quot' )
+ append '[ _ _ with-fp-traps ] ;
+
+: test-traps-compiled ( traps inputs quot -- quot' )
+ swapd '[ _ [ _ _ with-fp-traps ] compile-call ] ;
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail
+{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail
+{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail
+
+! Ensure ordered comparisons raise traps
+:: test-comparison-quot ( word -- quot )
+ [
+ { float float } declare
+ { +fp-invalid-operation+ } [ word execute ] with-fp-traps
+ ] ;
+
+: test-comparison ( inputs word -- quot )
+ test-comparison-quot append ;
+
+: test-comparison-compiled ( inputs word -- quot )
+ test-comparison-quot '[ @ _ compile-call ] ;
+
+\ float< "intrinsic" word-prop [
+ [ 0/0. -15.0 ] \ < test-comparison must-fail
+ [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ < test-comparison must-fail
+ [ -15.0 0/0. ] \ < test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ <= test-comparison must-fail
+ [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ <= test-comparison must-fail
+ [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ > test-comparison must-fail
+ [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ > test-comparison must-fail
+ [ -15.0 0/0. ] \ > test-comparison-compiled must-fail
+ [ 0/0. -15.0 ] \ >= test-comparison must-fail
+ [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail
+ [ -15.0 0/0. ] \ >= test-comparison must-fail
+ [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail
+
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test
+ [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test
+ [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test
+] when
! Ensure traps get cleared
[ 1/0. ] [ 1.0 0.0 /f ] unit-test
: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
: collect-fp-exceptions ( quot -- exceptions )
- clear-fp-exception-flags call fp-exception-flags ; inline
+ [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
\ <= define-math-ops
\ > define-math-ops
\ >= define-math-ops
+
+ \ u< define-math-ops
+ \ u<= define-math-ops
+ \ u> define-math-ops
+ \ u>= define-math-ops
+
\ number= define-math-ops
{ { shift bignum bignum } bignum-shift } ,
\ float/f { float float } { float } define-primitive
\ float/f make-foldable
-\ float< { float float } { object } define-primitive
-\ float< make-foldable
-
\ float-mod { float float } { float } define-primitive
\ float-mod make-foldable
+\ float< { float float } { object } define-primitive
+\ float< make-foldable
+
\ float<= { float float } { object } define-primitive
\ float<= make-foldable
\ float>= { float float } { object } define-primitive
\ float>= make-foldable
+\ float-u< { float float } { object } define-primitive
+\ float-u< make-foldable
+
+\ float-u<= { float float } { object } define-primitive
+\ float-u<= make-foldable
+
+\ float-u> { float float } { object } define-primitive
+\ float-u> make-foldable
+
+\ float-u>= { float float } { object } define-primitive
+\ float-u>= make-foldable
+
\ <word> { object object } { word } define-primitive
\ <word> make-flushable
{ "float<=" "math.private" (( x y -- ? )) }
{ "float>" "math.private" (( x y -- ? )) }
{ "float>=" "math.private" (( x y -- ? )) }
+ { "float-u<" "math.private" (( x y -- ? )) }
+ { "float-u<=" "math.private" (( x y -- ? )) }
+ { "float-u>" "math.private" (( x y -- ? )) }
+ { "float-u>=" "math.private" (( x y -- ? )) }
{ "<word>" "words" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
{ "getenv" "kernel.private" (( n -- obj )) }
HELP: float>= ( x y -- ? )
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
-{ $description "Primitive version of " { $link >= } "." }
-{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+{ $description "Primitive version of " { $link u>= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
-ARTICLE: "floats" "Floats"
-{ $subsection float }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+HELP: float-u< ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u< } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ;
+
+HELP: float-u<= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u<= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ;
+
+HELP: float-u> ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u> } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ;
+
+HELP: float-u>= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u>= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
+
+ARTICLE: "math.floats.compare" "Floating point comparison operations"
+"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:"
+{ $code
+ "a < b"
+ "a = b"
+ "a > b"
+}
+"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values."
$nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "1+3/4" }
-{ $example "5/4 0.5 + ." "1.75" }
-"Integers and rationals can be converted to floats:"
-{ $subsection >float }
-"Two real numbers can be divided yielding a float result:"
-{ $subsection /f }
+"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)."
+$nl
+"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons."
+$nl
+"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:"
+{ $subsection u< }
+{ $subsection u<= }
+{ $subsection u> }
+{ $subsection u>= }
+"A word to check if two values are unordered with respect to each other:"
+{ $subsection unordered? }
+"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary."
+$nl
+"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ;
+
+ARTICLE: "math.floats.bitwise" "Bitwise operations on floats"
"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
{ $subsection float>bits }
{ $subsection double>bits }
{ $subsection fp-snan? }
{ $subsection fp-infinity? }
{ $subsection fp-nan-payload }
-"Comparing two floating point numbers:"
+"Comparing two floating point numbers for bitwise equality:"
{ $subsection fp-bitwise= }
-{ $see-also "syntax-floats" } ;
+{ $see-also POSTPONE: NAN: } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Floating point literal syntax is documented in " { $link "syntax-floats" } "."
+$nl
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+{ $subsection "math.floats.bitwise" }
+{ $subsection "math.floats.compare" }
+"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ;
ABOUT: "floats"
USING: kernel math math.private ;
IN: math.floats.private
+: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
: float-min ( x y -- z ) [ float< ] most ; foldable
: float-max ( x y -- z ) [ float> ] most ; foldable
M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
M: float number= float= ; inline
-M: float < float< ; inline
+M: float < float< ; inline
M: float <= float<= ; inline
-M: float > float> ; inline
+M: float > float> ; inline
M: float >= float>= ; inline
+M: float unordered? float-unordered? ; inline
+M: float u< float-u< ; inline
+M: float u<= float-u<= ; inline
+M: float u> float-u> ; inline
+M: float u>= float-u>= ; inline
+
M: float + float+ ; inline
M: float - float- ; inline
M: float * float* ; inline
] if
] if ; inline
-M: float unordered? [ fp-nan? ] bi@ or ; inline
-
M: float prev-float
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
M: fixnum > fixnum> ; inline
M: fixnum >= fixnum>= ; inline
+M: fixnum u< fixnum< ; inline
+M: fixnum u<= fixnum<= ; inline
+M: fixnum u> fixnum> ; inline
+M: fixnum u>= fixnum>= ; inline
+
M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
M: bignum > bignum> ; inline
M: bignum >= bignum>= ; inline
+M: bignum u< bignum< ; inline
+M: bignum u<= bignum<= ; inline
+M: bignum u> bignum> ; inline
+M: bignum u>= bignum>= ; inline
+
M: bignum + bignum+ ; inline
M: bignum - bignum- ; inline
M: bignum * bignum* ; inline
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numeric value." }
-{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." }
+{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers."
+$nl
+"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." }
{ $examples
{ $example "USING: math prettyprint ;" "3.0 3 number= ." "t" }
{ $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" }
HELP: <
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: <=
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: >=
{ $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: unordered?
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ;
+HELP: u<
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u<=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
+HELP: fp-sign
+{ $values { "x" float } { "?" "a boolean" } }
+{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ;
+
HELP: fp-nan-payload
{ $values { "x" real } { "bits" integer } }
{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
+
MATH: unordered? ( x y -- ? ) foldable
+MATH: u< ( x y -- ? ) foldable
+MATH: u<= ( x y -- ? ) foldable
+MATH: u> ( x y -- ? ) foldable
+MATH: u>= ( x y -- ? ) foldable
M: object unordered? 2drop f ;
primitive_float_lesseq,
primitive_float_greater,
primitive_float_greatereq,
+ /* The unordered comparison primitives don't have a non-optimizing
+ compiler implementation */
+ primitive_float_less,
+ primitive_float_lesseq,
+ primitive_float_greater,
+ primitive_float_greatereq,
primitive_word,
primitive_word_xt,
primitive_getenv,
projects / factor.git / commitdiff