From 6d328be69b66e97498b53a22937e1e674a2b11bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 18:13:25 -0500 Subject: [PATCH 01/10] all-fp-exceptions constant --- basis/math/floats/env/env.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..91419c1fdf 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -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+ From 6ce3c1d62c02e969e58e406d1a279c5254a454b8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:43:23 -0500 Subject: [PATCH 02/10] CFSTRING: syntax for defining CF/Cocoa string constants. update core-foundation.run-loop to use CFSTRING: --- basis/core-foundation/run-loop/run-loop.factor | 6 +----- basis/core-foundation/strings/strings.factor | 5 +++++ 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 6446eacd08..10d858a32f 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer ( CFStringRef mode ) ; -: CFRunLoopDefaultMode ( -- alien ) - #! Ugly, but we don't have static NSStrings - \ CFRunLoopDefaultMode [ - "kCFRunLoopDefaultMode" - ] initialize-alien ; +CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" TUPLE: run-loop fds sources timers ; diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 413709d142..45f4460d13 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString ( : ( seq -- alien ) [ [ &CFRelease ] map ] with-destructors ; + +SYNTAX: CFSTRING: + CREATE scan-object + [ drop ] [ '[ _ [ _ ] initialize-alien ] ] 2bi + (( -- alien )) define-declared ; From e70fa134b299cd934386785d548a686f85f91cee Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:43:57 -0500 Subject: [PATCH 03/10] add full complement of [SU]Int[0-9]+ typedefs to core-foundation --- basis/core-foundation/core-foundation.factor | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 63bfaf37ce..2ef388563e 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -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 + From 569db73858a1289c1c4c69d3a6f71bab2f2db2c0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:44:13 -0500 Subject: [PATCH 04/10] QTKit binding --- extra/qtkit/qtkit.factor | 76 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 extra/qtkit/qtkit.factor diff --git a/extra/qtkit/qtkit.factor b/extra/qtkit/qtkit.factor new file mode 100644 index 0000000000..d0567bdd48 --- /dev/null +++ b/extra/qtkit/qtkit.factor @@ -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 + From 53e23de104e92edceb300c7bdec4ca920b6dfd42 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 20:39:41 -0500 Subject: [PATCH 05/10] set altivec denormal flag when with-denormal-mode is used --- basis/math/floats/env/ppc/ppc.factor | 42 +++++++++++++++++++++++++++- vm/Config.macosx.ppc | 2 +- vm/cpu-ppc.S | 23 +++++++++++++++ 3 files changed, 65 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index c4c81471ca..748f149ccd 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -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 (struct) [ get_ppc_fpu_env ] keep ; +: ( -- 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) - 1array ; + 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: 8000 + +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 (get-denormal-mode) ( register mode -- register ) + [ + { + { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } + { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] } + } case + ] curry change-vscr ; inline + diff --git a/vm/Config.macosx.ppc b/vm/Config.macosx.ppc index ed3c0d5a19..9fb84d6185 100644 --- a/vm/Config.macosx.ppc +++ b/vm/Config.macosx.ppc @@ -1,3 +1,3 @@ include vm/Config.macosx include vm/Config.ppc -CFLAGS += -arch ppc +CFLAGS += -arch ppc -force_cpusubtype_ALL diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 67c9e8d142..007638189a 100644 --- a/vm/cpu-ppc.S +++ b/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 + From f890f39d7c5b7e87818406b56a8f962b54aaddde Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 21:45:57 -0500 Subject: [PATCH 06/10] math.parser: fix example --- core/math/parser/parser-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index af4c712836..ebb9c8aa5e 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -103,7 +103,7 @@ HELP: >hex { $example "USING: math.parser prettyprint ;" "-15.5 >hex ." - "\"-f.8p0\"" + "\"-1.fp3\"" } } ; From 32b95c2cdfda7b9e7139127e4f8c78199bf80b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:20:13 -0500 Subject: [PATCH 07/10] math: add unordered comparison operators u< u<= u> u>= which behave exactly like < <= > >= except no floating point exceptions are set if one or both inputs are NaNs; also add efficient intrinsic for unordered? predicate, and fix propagation type functions for abs, absq, and bitnot --- .../cfg/intrinsics/float/float.factor | 5 +- .../compiler/cfg/intrinsics/intrinsics.factor | 15 +- basis/compiler/tests/float.factor | 12 ++ .../tree/comparisons/comparisons.factor | 36 +++-- .../known-words/known-words.factor | 56 ++++---- .../tree/propagation/propagation-tests.factor | 65 +++++++++ basis/math/floats/env/env-tests.factor | 130 ++++++++++++------ basis/math/floats/env/env.factor | 2 +- .../partial-dispatch/partial-dispatch.factor | 6 + .../known-words/known-words.factor | 18 ++- core/bootstrap/primitives.factor | 4 + core/math/floats/floats-docs.factor | 79 +++++++++-- core/math/floats/floats.factor | 13 +- core/math/integers/integers.factor | 10 ++ core/math/math-docs.factor | 43 +++++- core/math/math.factor | 7 +- vm/primitives.cpp | 6 + 17 files changed, 396 insertions(+), 111 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 8dab157f4e..8a65de5805 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -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 ( -- ) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec567558bd..a54caf23de 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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 ] } diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 86d7899fab..14b347008c 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -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 diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5f4b1e8dab..b8e79e33ca 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/basis/compiler/tree/comparisons/comparisons.factor @@ -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' ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 5fe7d5ee1b..63d2df543d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -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 ] 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 + @ + + ] "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 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 1b24bc0c8f..ec5fbd95cd 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 [ diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index a0ffa0713c..0c38d69ea9 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -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 diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..ba198168da 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -102,7 +102,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) ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6679e81fcd..7c66c911de 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -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 } , diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ea8f6f5f49..0de957b785 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -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 + \ { object object } { word } define-primitive \ make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 13e17f90fd..355fa8ed58 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 -- ? )) } { "" "words" (( name vocab -- word )) } { "word-xt" "words" (( word -- start end )) } { "getenv" "kernel.private" (( n -- obj )) } diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index ed4947e1f5..6e903a37e2 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -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" diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 9c49e99231..bc419b94c5 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -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 diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index ed25e3bfa6..e684b8edfb 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -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 diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 97e0a1e7cf..e5de106bbb 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -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 } "." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 900c1e1cee..8ef4f38f9a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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 ; diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 2359173d9b..6dbe281d0c 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -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, From 3a61107f1dab168787a4ae41b9297022dba97810 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:30:11 -0500 Subject: [PATCH 08/10] typos in altivec env --- basis/math/floats/env/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index 748f149ccd..4ce3f0512e 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -90,7 +90,7 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-fpscr ; inline -CONSTANT: vmx-denormal-mode-bits HEX: 8000 +CONSTANT: vmx-denormal-mode-bits HEX: 10000 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) drop { } ; inline @@ -109,7 +109,7 @@ M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) 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 (get-denormal-mode) ( register mode -- register ) +M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) [ { { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } From 7b36689416819ca0bc290f5b0fa5341e7cc78c41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:24 -0500 Subject: [PATCH 09/10] core-foundation.strings: fix load error --- basis/core-foundation/strings/strings.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 45f4460d13..4bbe050230 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -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 From 4686063d0fe65a03d69f07e1b0d8b26b60aa3641 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:45 -0500 Subject: [PATCH 10/10] qtkit: add tags and authors --- extra/qtkit/authors.txt | 1 + extra/qtkit/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 extra/qtkit/authors.txt create mode 100644 extra/qtkit/tags.txt diff --git a/extra/qtkit/authors.txt b/extra/qtkit/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qtkit/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qtkit/tags.txt b/extra/qtkit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/qtkit/tags.txt @@ -0,0 +1 @@ +unportable