diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 9492304628..34fcf8e6bc 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -97,10 +97,10 @@ M: relative-overflow summary : assert-depth ( quot -- ) >r datastack r> swap slip >r datastack r> - 2dup [ length ] compare sgn { - { -1 [ trim-datastacks nip relative-underflow ] } - { 0 [ 2drop ] } - { 1 [ trim-datastacks drop relative-overflow ] } + 2dup [ length ] compare { + { +lt+ [ trim-datastacks nip relative-underflow ] } + { +eq+ [ 2drop ] } + { +gt+ [ trim-datastacks drop relative-overflow ] } } case ; inline : expired-error. ( obj -- ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index d71749804b..90590fe565 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -23,7 +23,7 @@ PREDICATE: math-class < class } cond ; : math-class-max ( class class -- class ) - [ [ math-precedence ] compare 0 > ] most ; + [ [ math-precedence ] compare +gt+ eq? ] most ; : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 54eb93a201..57f0e0ac72 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n ) GENERIC: heap-compare ( pair1 pair2 heap -- ? ) -: (heap-compare) drop [ entry-key ] compare 0 ; inline +: (heap-compare) drop [ entry-key ] compare ; inline -M: min-heap heap-compare (heap-compare) > ; +M: min-heap heap-compare (heap-compare) +gt+ eq? ; -M: max-heap heap-compare (heap-compare) < ; +M: max-heap heap-compare (heap-compare) +lt+ eq? ; : heap-bounds-check? ( m heap -- ? ) heap-size >= ; inline diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 2e1a69e407..5896429ccf 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ; : value-vector ( n -- vector ) [ drop ] V{ } map-as ; : add-inputs ( seq stack -- n stack ) - tuck [ length ] compare dup 0 > + tuck [ length ] bi@ - dup 0 > [ dup value-vector [ swapd push-all ] keep ] [ drop 0 swap ] if ; diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index 029d41efa8..42a8d8123f 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -9,17 +9,26 @@ HELP: <=> $nl "The output value is one of the following:" { $list - { "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } } - { "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } } - { "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } } + { { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } } + { { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } } + { { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } } } "The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically." } ; +HELP: +lt+ +{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ; + +HELP: +eq+ +{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ; + +HELP: +gt+ +{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ; + HELP: compare -{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } } +{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } } { $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." } -{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" } +{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" } } ; HELP: max diff --git a/core/math/order/order-tests.factor b/core/math/order/order-tests.factor index 6dbaf29e7c..665537be5d 100644 --- a/core/math/order/order-tests.factor +++ b/core/math/order/order-tests.factor @@ -1,6 +1,9 @@ USING: kernel math.order tools.test ; IN: math.order.tests -[ -1 ] [ "ab" "abc" <=> ] unit-test -[ 1 ] [ "abc" "ab" <=> ] unit-test +[ +lt+ ] [ "ab" "abc" <=> ] unit-test +[ +gt+ ] [ "abc" "ab" <=> ] unit-test +[ +lt+ ] [ 3 4 <=> ] unit-test +[ +eq+ ] [ 4 4 <=> ] unit-test +[ +gt+ ] [ 4 3 <=> ] unit-test diff --git a/core/math/order/order.factor b/core/math/order/order.factor index eb781d1967..1262d89ee0 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -3,20 +3,26 @@ USING: kernel math ; IN: math.order +SYMBOL: +lt+ +SYMBOL: +eq+ +SYMBOL: +gt+ + GENERIC: <=> ( obj1 obj2 -- n ) -M: real <=> - ; -M: integer <=> - ; +: (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ; + +M: real <=> (<=>) ; +M: integer <=> (<=>) ; GENERIC: before? ( obj1 obj2 -- ? ) GENERIC: after? ( obj1 obj2 -- ? ) GENERIC: before=? ( obj1 obj2 -- ? ) GENERIC: after=? ( obj1 obj2 -- ? ) -M: object before? ( obj1 obj2 -- ? ) <=> 0 < ; -M: object after? ( obj1 obj2 -- ? ) <=> 0 > ; -M: object before=? ( obj1 obj2 -- ? ) <=> 0 <= ; -M: object after=? ( obj1 obj2 -- ? ) <=> 0 >= ; +M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; +M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; +M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; +M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; M: real before? ( obj1 obj2 -- ? ) < ; M: real after? ( obj1 obj2 -- ? ) > ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 6aafe2ded1..fa8d50ea0e 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -17,7 +17,7 @@ DEFER: sort dup slice-from 1+ swap set-slice-from ; inline : smallest ( iter1 iter2 quot -- elt ) - >r over this over this r> call 0 < + >r over this over this r> call +lt+ eq? -rot ? [ this ] keep next ; inline : (merge) ( iter1 iter2 quot accum -- ) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ad5a40ed6d..0dc5601cd0 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -66,9 +66,9 @@ MACRO: firstn ( n -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: higher ( a b quot -- c ) [ compare 0 > ] curry most ; inline +: higher ( a b quot -- c ) [ compare +gt+ eq? ] curry most ; inline -: lower ( a b quot -- c ) [ compare 0 < ] curry most ; inline +: lower ( a b quot -- c ) [ compare +lt+ eq? ] curry most ; inline ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!