Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
51a3ca5b90
|
|
@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float
|
|||
: 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 ( -- )
|
||||
|
|
|
|||
|
|
@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics
|
|||
{ 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 ] }
|
||||
|
|
|
|||
|
|
@ -88,3 +88,15 @@ IN: compiler.tests.float
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,28 +1,36 @@
|
|||
! 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' )
|
||||
|
|
@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
|
|||
{ > < }
|
||||
{ <= >= }
|
||||
{ >= <= }
|
||||
{ u< u> }
|
||||
{ u> u< }
|
||||
{ u<= u>= }
|
||||
{ u>= u<= }
|
||||
} at ;
|
||||
|
||||
: negate-comparison ( op -- op' )
|
||||
|
|
@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
|
|||
{ > <= }
|
||||
{ <= > }
|
||||
{ >= < }
|
||||
{ u< u>= }
|
||||
{ u> u<= }
|
||||
{ u<= u> }
|
||||
{ u>= u< }
|
||||
} at ;
|
||||
|
||||
: specific-comparison ( op -- op' )
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words
|
|||
{ + - * / }
|
||||
[ { 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 }
|
||||
|
|
@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words
|
|||
|
||||
\ 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 ;
|
||||
|
|
@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -101,6 +77,36 @@ IN: compiler.tree.propagation.known-words
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ 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
|
||||
|
|
@ -164,6 +166,18 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ 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
|
||||
|
|
@ -247,6 +261,13 @@ IN: compiler.tree.propagation.tests
|
|||
] 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
|
||||
|
|
@ -254,6 +275,13 @@ IN: compiler.tree.propagation.tests
|
|||
] 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
|
||||
|
|
@ -261,6 +289,13 @@ IN: compiler.tree.propagation.tests
|
|||
] 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
|
||||
|
|
@ -269,6 +304,14 @@ IN: compiler.tree.propagation.tests
|
|||
[ 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
|
||||
|
|
@ -277,6 +320,10 @@ IN: compiler.tree.propagation.tests
|
|||
[ 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 {
|
||||
|
|
@ -300,10 +347,18 @@ IN: compiler.tree.propagation.tests
|
|||
[ >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
|
||||
|
|
@ -312,12 +367,22 @@ IN: compiler.tree.propagation.tests
|
|||
[ 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 [
|
||||
|
|
|
|||
|
|
@ -8,11 +8,16 @@ TYPEDEF: void* CFTypeRef
|
|||
TYPEDEF: void* CFAllocatorRef
|
||||
CONSTANT: kCFAllocatorDefault f
|
||||
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: long CFIndex
|
||||
TYPEDEF: char UInt8
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: uint UInt32
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: long CFIndex
|
||||
TYPEDEF: uchar UInt8
|
||||
TYPEDEF: ushort UInt16
|
||||
TYPEDEF: uint UInt32
|
||||
TYPEDEF: ulonglong UInt64
|
||||
TYPEDEF: char SInt8
|
||||
TYPEDEF: short SInt16
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: longlong SInt64
|
||||
TYPEDEF: ulong CFTypeID
|
||||
TYPEDEF: UInt32 CFOptionFlags
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
|
|
@ -32,3 +37,4 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
|
|||
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
|
||||
|
||||
DESTRUCTOR: CFRelease
|
||||
|
||||
|
|
|
|||
|
|
@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer (
|
|||
CFStringRef mode
|
||||
) ;
|
||||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode [
|
||||
"kCFRunLoopDefaultMode" <CFString>
|
||||
] initialize-alien ;
|
||||
CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode"
|
||||
|
||||
TUPLE: run-loop fds sources timers ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax alien.strings io.encodings.string kernel
|
||||
sequences byte-arrays io.encodings.utf8 math core-foundation
|
||||
core-foundation.arrays destructors ;
|
||||
core-foundation.arrays destructors parser fry alien words ;
|
||||
IN: core-foundation.strings
|
||||
|
||||
TYPEDEF: void* CFStringRef
|
||||
|
|
@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
|
|||
|
||||
: <CFStringArray> ( seq -- alien )
|
||||
[ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
|
||||
|
||||
SYNTAX: CFSTRING:
|
||||
CREATE scan-object
|
||||
[ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
|
||||
(( -- alien )) define-declared ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
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 ( -- )
|
||||
|
|
@ -8,45 +9,29 @@ IN: math.floats.env.tests
|
|||
! 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
|
||||
: test-fp-exception ( exception inputs quot -- quot' )
|
||||
'[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
|
||||
|
||||
[ t ] [
|
||||
[ 1.0 3.0 / drop ] collect-fp-exceptions
|
||||
+fp-inexact+ swap member?
|
||||
] unit-test
|
||||
: test-fp-exception-compiled ( exception inputs quot -- quot' )
|
||||
'[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
|
||||
|
||||
[ t ] [
|
||||
[ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
|
||||
+fp-overflow+ swap member?
|
||||
] unit-test
|
||||
[ 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 ] [
|
||||
[ 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
|
||||
[ 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
|
||||
|
|
@ -117,11 +102,72 @@ set-default-fp-env
|
|||
-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
|
||||
|
|
|
|||
|
|
@ -18,6 +18,15 @@ UNION: fp-exception
|
|||
+fp-zero-divide+
|
||||
+fp-inexact+ ;
|
||||
|
||||
CONSTANT: all-fp-exceptions
|
||||
{
|
||||
+fp-invalid-operation+
|
||||
+fp-overflow+
|
||||
+fp-underflow+
|
||||
+fp-zero-divide+
|
||||
+fp-inexact+
|
||||
}
|
||||
|
||||
SINGLETONS:
|
||||
+round-nearest+
|
||||
+round-down+
|
||||
|
|
@ -102,7 +111,7 @@ PRIVATE>
|
|||
: 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) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,19 +7,32 @@ STRUCT: ppc-fpu-env
|
|||
{ padding uint }
|
||||
{ fpscr uint } ;
|
||||
|
||||
STRUCT: ppc-vmx-env
|
||||
{ vscr uint } ;
|
||||
|
||||
! defined in the vm, cpu-ppc*.S
|
||||
FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
|
||||
FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
|
||||
|
||||
FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
|
||||
FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
|
||||
|
||||
: <ppc-fpu-env> ( -- ppc-fpu-env )
|
||||
ppc-fpu-env (struct)
|
||||
[ get_ppc_fpu_env ] keep ;
|
||||
|
||||
: <ppc-vmx-env> ( -- ppc-fpu-env )
|
||||
ppc-vmx-env (struct)
|
||||
[ get_ppc_vmx_env ] keep ;
|
||||
|
||||
M: ppc-fpu-env (set-fp-env-register)
|
||||
set_ppc_fpu_env ;
|
||||
|
||||
M: ppc-vmx-env (set-fp-env-register)
|
||||
set_ppc_vmx_env ;
|
||||
|
||||
M: ppc (fp-env-registers)
|
||||
<ppc-fpu-env> 1array ;
|
||||
<ppc-fpu-env> <ppc-vmx-env> 2array ;
|
||||
|
||||
CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
|
||||
CONSTANT: ppc-exception-flag>bit
|
||||
|
|
@ -77,3 +90,30 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
|
|||
} case
|
||||
] curry change-fpscr ; inline
|
||||
|
||||
CONSTANT: vmx-denormal-mode-bits HEX: 10000
|
||||
|
||||
M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
|
||||
drop { } ; inline
|
||||
M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
|
||||
drop ;
|
||||
|
||||
M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
|
||||
drop { } ; inline
|
||||
M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
|
||||
drop ;
|
||||
|
||||
M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
|
||||
drop +round-nearest+ ;
|
||||
M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
|
||||
drop ;
|
||||
|
||||
M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
|
||||
vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
|
||||
M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
|
||||
[
|
||||
{
|
||||
{ +denormal-keep+ [ vmx-denormal-mode-bits unmask ] }
|
||||
{ +denormal-flush+ [ vmx-denormal-mode-bits bitor ] }
|
||||
} case
|
||||
] curry change-vscr ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -197,6 +197,12 @@ SYMBOL: fast-math-ops
|
|||
\ <= 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 } ,
|
||||
|
|
|
|||
|
|
@ -455,12 +455,12 @@ M: bad-executable summary
|
|||
\ 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
|
||||
|
||||
|
|
@ -470,6 +470,18 @@ M: bad-executable summary
|
|||
\ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -409,6 +409,10 @@ tuple
|
|||
{ "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 )) }
|
||||
|
|
|
|||
|
|
@ -69,20 +69,54 @@ HELP: float> ( x y -- ? )
|
|||
|
||||
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 }
|
||||
|
|
@ -100,8 +134,25 @@ $nl
|
|||
{ $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"
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
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
|
||||
|
||||
|
|
@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline
|
|||
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
|
||||
|
|
@ -58,8 +65,6 @@ M: float next-float
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline
|
|||
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
|
||||
|
|
@ -65,6 +70,11 @@ M: bignum <= bignum<= ; 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
|
||||
|
|
|
|||
|
|
@ -5,7 +5,9 @@ IN: math
|
|||
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" }
|
||||
|
|
@ -13,20 +15,47 @@ HELP: number=
|
|||
|
||||
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 } }
|
||||
|
|
@ -328,6 +357,10 @@ HELP: fp-infinity?
|
|||
{ $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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! 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
|
||||
|
|
@ -22,7 +22,12 @@ MATH: < ( x y -- ? ) foldable
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ HELP: >hex
|
|||
{ $example
|
||||
"USING: math.parser prettyprint ;"
|
||||
"-15.5 >hex ."
|
||||
"\"-f.8p0\""
|
||||
"\"-1.fp3\""
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
USING: classes.struct cocoa core-foundation.strings ;
|
||||
IN: qtkit
|
||||
|
||||
STRUCT: QTTime
|
||||
{ timeValue longlong }
|
||||
{ timeScale long }
|
||||
{ flags long } ;
|
||||
|
||||
STRUCT: QTTimeRange
|
||||
{ time QTTime }
|
||||
{ duration QTTime } ;
|
||||
|
||||
STRUCT: SMPTETime
|
||||
{ mSubframes SInt16 }
|
||||
{ mSubframeDivisor SInt16 }
|
||||
{ mCounter UInt32 }
|
||||
{ mType UInt32 }
|
||||
{ mFlags UInt32 }
|
||||
{ mHours SInt16 }
|
||||
{ mMinutes SInt16 }
|
||||
{ mSeconds SInt16 }
|
||||
{ mFrames SInt16 } ;
|
||||
|
||||
CFSTRING: QTKitErrorDomain "QTKitErrorDomain"
|
||||
CFSTRING: QTErrorCaptureInputKey "QTErrorCaptureInputKey"
|
||||
CFSTRING: QTErrorCaptureOutputKey "QTErrorCaptureOutputKey"
|
||||
CFSTRING: QTErrorDeviceKey "QTErrorDeviceKey"
|
||||
CFSTRING: QTErrorExcludingDeviceKey "QTErrorExcludingDeviceKey"
|
||||
CFSTRING: QTErrorTimeKey "QTErrorTimeKey"
|
||||
CFSTRING: QTErrorFileSizeKey "QTErrorFileSizeKey"
|
||||
CFSTRING: QTErrorRecordingSuccesfullyFinishedKey "QTErrorRecordingSuccesfullyFinishedKey"
|
||||
|
||||
CONSTANT: QTErrorUnknown -1
|
||||
CONSTANT: QTErrorIncompatibleInput 1002
|
||||
CONSTANT: QTErrorIncompatibleOutput 1003
|
||||
CONSTANT: QTErrorInvalidInputsOrOutputs 1100
|
||||
CONSTANT: QTErrorDeviceAlreadyUsedbyAnotherSession 1101
|
||||
CONSTANT: QTErrorNoDataCaptured 1200
|
||||
CONSTANT: QTErrorSessionConfigurationChanged 1201
|
||||
CONSTANT: QTErrorDiskFull 1202
|
||||
CONSTANT: QTErrorDeviceWasDisconnected 1203
|
||||
CONSTANT: QTErrorMediaChanged 1204
|
||||
CONSTANT: QTErrorMaximumDurationReached 1205
|
||||
CONSTANT: QTErrorMaximumFileSizeReached 1206
|
||||
CONSTANT: QTErrorMediaDiscontinuity 1207
|
||||
CONSTANT: QTErrorMaximumNumberOfSamplesForFileFormatReached 1208
|
||||
CONSTANT: QTErrorDeviceNotConnected 1300
|
||||
CONSTANT: QTErrorDeviceInUseByAnotherApplication 1301
|
||||
CONSTANT: QTErrorDeviceExcludedByAnotherDevice 1302
|
||||
|
||||
FRAMEWORK: /System/Library/Frameworks/QTKit.framework
|
||||
|
||||
IMPORT: QTCaptureAudioPreviewOutput
|
||||
IMPORT: QTCaptureConnection
|
||||
IMPORT: QTCaptureDecompressedAudioOutput
|
||||
IMPORT: QTCaptureDecompressedVideoOutput
|
||||
IMPORT: QTCaptureDevice
|
||||
IMPORT: QTCaptureDeviceInput
|
||||
IMPORT: QTCaptureFileOutput
|
||||
IMPORT: QTCaptureInput
|
||||
IMPORT: QTCaptureLayer
|
||||
IMPORT: QTCaptureMovieFileOutput
|
||||
IMPORT: QTCaptureOutput
|
||||
IMPORT: QTCaptureSession
|
||||
IMPORT: QTCaptureVideoPreviewOutput
|
||||
IMPORT: QTCaptureView
|
||||
IMPORT: QTCompressionOptions
|
||||
IMPORT: QTDataReference
|
||||
IMPORT: QTFormatDescription
|
||||
IMPORT: QTMedia
|
||||
IMPORT: QTMovie
|
||||
IMPORT: QTMovieLayer
|
||||
IMPORT: QTMovieView
|
||||
IMPORT: QTSampleBuffer
|
||||
IMPORT: QTTrack
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -1,3 +1,3 @@
|
|||
include vm/Config.macosx
|
||||
include vm/Config.ppc
|
||||
CFLAGS += -arch ppc
|
||||
CFLAGS += -arch ppc -force_cpusubtype_ALL
|
||||
|
|
|
|||
23
vm/cpu-ppc.S
23
vm/cpu-ppc.S
|
|
@ -254,3 +254,26 @@ DEF(void,set_ppc_fpu_env,(const void*)):
|
|||
lfd f0,0(r3)
|
||||
mtfsf 0xff,f0
|
||||
blr
|
||||
|
||||
DEF(void,get_ppc_vmx_env,(void*)):
|
||||
mfvscr v0
|
||||
subi r4,r1,16
|
||||
li r5,0xf
|
||||
andc r4,r4,r5
|
||||
li r5,0xc
|
||||
stvewx v0,r5,r4
|
||||
lwzx r6,r5,r4
|
||||
stw r6,0(r3)
|
||||
blr
|
||||
|
||||
DEF(void,set_ppc_vmx_env,(const void*)):
|
||||
subi r4,r1,16
|
||||
li r5,0xf
|
||||
andc r4,r4,r5
|
||||
li r5,0xc
|
||||
lwz r6,0(r3)
|
||||
stwx r6,r5,r4
|
||||
lvewx v0,r5,r4
|
||||
mtvscr v0
|
||||
blr
|
||||
|
||||
|
|
|
|||
|
|
@ -51,6 +51,12 @@ const primitive_type primitives[] = {
|
|||
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,
|
||||
|
|
|
|||
Loading…
Reference in New Issue