test-foo
-[ 1 ] [ "x" get NSRect-x ] unit-test
-[ 2 ] [ "x" get NSRect-y ] unit-test
-[ 101 ] [ "x" get NSRect-w ] unit-test
-[ 102 ] [ "x" get NSRect-h ] unit-test
+[ 1.0 ] [ "x" get NSRect-x ] unit-test
+[ 2.0 ] [ "x" get NSRect-y ] unit-test
+[ 101.0 ] [ "x" get NSRect-w ] unit-test
+[ 102.0 ] [ "x" get NSRect-h ] unit-test
CLASS: {
{ +superclass+ "NSObject" }
\ detect-float inlined?
] unit-test
-[ t ] [
- [ 3 + = ] \ equal? inlined?
-] unit-test
-
[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift-fast inlined?
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences
-compiler.tree compiler.tree.combinators ;
+USING: kernel accessors sequences words namespaces
+classes.builtin
+compiler.tree
+compiler.tree.builder
+compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.cleanup
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.combinators ;
IN: compiler.tree.finalization
GENERIC: finalize* ( node -- nodes )
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
+: builtin-predicate? ( word -- ? )
+ "predicating" word-prop builtin-class? ;
+
+: splice-quot ( quot -- nodes )
+ [
+ build-tree
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ remove-dead-code
+ but-last
+ ] with-scope ;
+
+M: #call finalize*
+ dup word>> builtin-predicate? [
+ word>> def>> splice-quot
+ ] when ;
+
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
\ eq? [
[ info-intervals-intersect? ]
[ info-classes-intersect? ]
- 2bi or maybe-or-never
+ 2bi and maybe-or-never
] "outputs" set-word-prop
{
] final-classes
] unit-test
+[ V{ POSTPONE: f } ] [
+ [ { float } declare 0 eq? ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
math.complex.private ;
IN: math.complex
+ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers"
+"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
+{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
+"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
+{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" }
+"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
+
ARTICLE: "complex-numbers" "Complex numbers"
{ $subsection complex }
"Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "."
$nl
-"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero."
-$nl
"Complex numbers can be taken apart:"
{ $subsection real-part }
{ $subsection imaginary-part }
{ $subsection >rect }
"Complex numbers can be constructed from real numbers:"
{ $subsection rect> }
+{ $subsection "complex-numbers-zero" }
{ $see-also "syntax-complex-numbers" } ;
HELP: complex
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
[ 1 C{ 0 1 } rect> ] must-fail
[ C{ 0 1 } 1 rect> ] must-fail
-[ f ] [ C{ 5 12.5 } 5 = ] unit-test
-[ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
-[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
+[ f ] [ C{ 5 12.5 } 5 = ] unit-test
+[ f ] [ C{ 5 12.5 } 5 number= ] unit-test
+
+[ f ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test
+[ t ] [ C{ 1.0 2.0 } C{ 1 2 } number= ] unit-test
+
+[ f ] [ C{ 1.0 2.3 } C{ 1 2 } = ] unit-test
+[ f ] [ C{ 1.0 2.3 } C{ 1 2 } number= ] unit-test
[ C{ 2 5 } ] [ 2 5 rect> ] unit-test
[ 2 5 ] [ C{ 2 5 } >rect ] unit-test
[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test
[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test
-[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test
+[ C{ 0.0 1.0 } ] [ 1.0 C{ 0 1 } * ] unit-test
[ -1 ] [ C{ 0 1 } C{ 0 1 } * ] unit-test
[ C{ 0 1 } ] [ 1 C{ 0 1 } * ] unit-test
[ C{ 0 1 } ] [ C{ 0 1 } 1 * ] unit-test
[ C{ -3 4 } ] [ C{ 3 -4 } neg ] unit-test
-[ 5 ] [ C{ 3 4 } abs ] unit-test
-[ 5 ] [ -5.0 abs ] unit-test
+[ 5.0 ] [ C{ 3 4 } abs ] unit-test
+[ 5.0 ] [ -5.0 abs ] unit-test
! Make sure arguments are sane
-[ 0 ] [ 0 arg ] unit-test
-[ 0 ] [ 1 arg ] unit-test
+[ 0.0 ] [ 0 arg ] unit-test
+[ 0.0 ] [ 1 arg ] unit-test
[ t ] [ -1 arg 3.14 3.15 between? ] unit-test
[ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test
[ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test
-[ 1 0 ] [ 1 >polar ] unit-test
-[ 1 ] [ -1 >polar drop ] unit-test
+[ 1.0 0.0 ] [ 1 >polar ] unit-test
+[ 1.0 ] [ -1 >polar drop ] unit-test
[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
! I broke something
[ [ real-part ] bi@ ] 2keep
[ imaginary-part ] bi@ ; inline
+M: complex hashcode*
+ nip >rect [ hashcode ] bi@ bitxor ;
+
+M: complex equal?
+ over complex? [
+ 2>rect = [ = ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
+
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
-M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ;
-
IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
HELP: rect>
{ $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." } ;
+{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ;
HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
[ 0.25 ] [ 2.0 -2.0 fpow ] unit-test
[ 4.0 ] [ 16 sqrt ] unit-test
-[ C{ 0 4.0 } ] [ -16 sqrt ] unit-test
+[ 2.0 ] [ 4.0 0.5 ^ ] unit-test
+[ C{ 0.0 4.0 } ] [ -16 sqrt ] unit-test
-[ 4.0 ] [ 2 2 ^ ] unit-test
-[ 0.25 ] [ 2 -2 ^ ] unit-test
+[ 4 ] [ 2 2 ^ ] unit-test
+[ 1/4 ] [ 2 -2 ^ ] unit-test
[ t ] [ 2 0.5 ^ 2 ^ 2 2.00001 between? ] unit-test
[ t ] [ e pi i* ^ real-part -1.0 = ] unit-test
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
[ 0 ] [ 0 3.0 ^ ] unit-test
[ 0 ] [ 0 3 ^ ] unit-test
+[ 0.0 ] [ 1 log ] unit-test
+
[ 1.0 ] [ 0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
<PRIVATE
: (rect>) ( x y -- z )
- dup zero? [ drop ] [ <complex> ] if ; inline
+ dup 0 = [ drop ] [ <complex> ] if ; inline
PRIVATE>
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot: ( ? -- ) -- )
- over 0 number= pick -1 number= or [
+ over 0 = pick -1 = or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline recursive
-GENERIC: (^) ( x y -- z ) foldable
-
: ^n ( z w -- z^w )
1 swap [
[ dupd * ] when >r sq r>
] each-bit nip ; inline
-M: integer (^)
- dup 0 < [ neg ^n recip ] [ ^n ] if ;
+: integer^ ( x y -- z )
+ dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
+
+: >rect ( z -- x y )
+ [ real-part ] [ imaginary-part ] bi ; inline
+
+: >float-rect ( z -- x y )
+ >rect [ >float ] bi@ ; inline
+
+: >polar ( z -- abs arg )
+ >float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ;
+ inline
+
+: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
+
+: polar> ( abs arg -- z ) cis * ; inline
+
+: ^mag ( w abs arg -- magnitude )
+ >r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
+ inline
+
+: ^theta ( w abs arg -- theta )
+ >r >r >float-rect r> flog * swap r> * + ; inline
+
+: ^complex ( x y -- z )
+ swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline
+
+: real^? ( x y -- ? )
+ 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
+
+: 0^ ( x -- z )
+ dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
: ^ ( x y -- z )
- over zero? [
- dup zero?
- [ 2drop 0.0 0.0 / ] [ 0 < [ drop 1.0 0.0 / ] when ] if
- ] [
- (^)
- ] if ; inline
+ {
+ { [ over zero? ] [ nip 0^ ] }
+ { [ dup integer? ] [ integer^ ] }
+ { [ 2dup real^? ] [ fpow ] }
+ [ ^complex ]
+ } cond ;
: (^mod) ( n x y -- z )
1 swap [
[ ~abs ]
} cond ;
-: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
-
: conjugate ( z -- z* ) >rect neg rect> ; inline
-: >float-rect ( z -- x y )
- >rect swap >float swap >float ; inline
-
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
-: >polar ( z -- abs arg )
- >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
- inline
-
-: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
-
-: polar> ( abs arg -- z ) cis * ; inline
-
-: ^mag ( w abs arg -- magnitude )
- >r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
- inline
-
-: ^theta ( w abs arg -- theta )
- >r >r >float-rect r> flog * swap r> * + ; inline
-
-M: number (^)
- swap >polar 3dup ^theta >r ^mag r> polar> ;
-
: [-1,1]? ( x -- ? )
dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline
-: exp ( x -- y ) >rect swap fexp swap polar> ; inline
+GENERIC: exp ( x -- y )
+
+M: real exp fexp ;
+
+M: complex exp >rect swap fexp swap polar> ;
+
+GENERIC: log ( x -- y )
+
+M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
-: log ( x -- y ) >polar swap flog swap rect> ; inline
+M: complex log >polar swap flog swap rect> ;
: cos ( x -- y )
dup complex? [
] unit-test
[ t ] [
- 1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] =
+ 1 2 [a,b] -0.5 0.5 [a,b] interval* -1.0 1.0 [a,b] =
] unit-test
[ t ] [
- 1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] =
+ 1 2 [a,b] -0.5 0.5 (a,b] interval* -1.0 1.0 (a,b] =
] unit-test
[ t ] [
"math.ratios.private" vocab [
[ t ] [
- -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) =
+ -1 1 (a,b) 0.5 1 (a,b) interval/ -2.0 2.0 (a,b) =
] unit-test
] when
[ -1/2 ] [ 1/2 1- ] unit-test
[ 3/2 ] [ 1/2 1+ ] unit-test
-[ 1 ] [ 0.5 1/2 + ] unit-test
-[ 1 ] [ 1/2 0.5 + ] unit-test
+[ 1.0 ] [ 0.5 1/2 + ] unit-test
+[ 1.0 ] [ 1/2 0.5 + ] unit-test
[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
2dup gcd nip tuck /i >r /i r> fraction>
] if ;
+M: ratio hashcode*
+ nip >fraction [ hashcode ] bi@ bitxor ;
+
+M: ratio equal?
+ over ratio? [
+ 2>fraction = [ = ] [ 2drop f ] if
+ ] [ 2drop f ] if ;
+
M: ratio number=
2>fraction number= [ number= ] [ 2drop f ] if ;
[ ] [
"IN: sequences TUPLE: reversed { seq read-only } ;" eval
] unit-test
+
+TUPLE: bogus-hashcode-1 x ;
+
+TUPLE: bogus-hashcode-2 x ;
+
+M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
+
+[ ] [ T{ bogus-hashcode-2 T{ bogus-hashcode-1 } } hashcode drop ] unit-test
M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
-[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+[ 30
.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
GENERIC: big-mix-test ( obj -- obj' )
[ t ] [ 12 hashcode 12 hashcode = ] unit-test
[ t ] [ 12 >bignum hashcode 12 hashcode = ] unit-test
-[ t ] [ 12.0 hashcode 12 >bignum hashcode = ] unit-test
! Test various odd keys to see if they work.
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality"
-"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
+"There are two distinct notions of ``sameness'' when it comes to objects."
$nl
-"Identity comparison:"
+"You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:"
{ $subsection eq? }
-"Value comparison:"
+"You can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "):"
{ $subsection = }
-"Custom value comparison methods:"
+"A third form of equality is provided by " { $link number= } ". It compares numeric value while disregarding types."
+$nl
+"Custom value comparison methods for use with " { $link = } " can be defined on a generic word:"
{ $subsection equal? }
"Utility class:"
{ $subsection identity-tuple }
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description
"Tests if two objects are equal. If " { $snippet "obj1" } " and " { $snippet "obj2" } " point to the same object, outputs " { $link t } ". Otherwise, calls the " { $link equal? } " generic word."
+}
+{ $examples
+ { $example "USING: kernel prettyprint ;" "5 5 = ." "t" }
+ { $example "USING: kernel prettyprint ;" "5 005 = ." "t" }
+ { $example "USING: kernel prettyprint ;" "5 5.0 = ." "f" }
+ { $example "USING: arrays kernel prettyprint ;" "{ \"a\" \"b\" } \"a\" \"b\" 2array = ." "t" }
+ { $example "USING: arrays kernel prettyprint ;" "{ \"a\" \"b\" } [ \"a\" \"b\" ] = ." "f" }
} ;
HELP: equal?
{ { $snippet "a = b" } " implies " { $snippet "b = a" } }
{ { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } }
}
- $nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
+}
+{ $examples
+ "An example demonstrating why this word should only be used to define methods on, and never called directly:"
+ { $example "USING: kernel prettyprint ;" "5 5 equal? ." "f" }
+ "Using " { $link = } " gives the expected behavior:"
+ { $example "USING: kernel prettyprint ;" "5 5 = ." "t" }
} ;
HELP: identity-tuple
[ t ] [ 3.1415 number? ] unit-test
[ f ] [ 12 float? ] unit-test
-[ t ] [ 1 1.0 = ] unit-test
-[ t ] [ 1 >bignum 1.0 = ] unit-test
-[ t ] [ 1.0 1 = ] unit-test
-[ t ] [ 1.0 1 >bignum = ] unit-test
+[ f ] [ 1 1.0 = ] unit-test
+[ t ] [ 1 1.0 number= ] unit-test
+
+[ f ] [ 1 >bignum 1.0 = ] unit-test
+[ t ] [ 1 >bignum 1.0 number= ] unit-test
+
+[ f ] [ 1.0 1 = ] unit-test
+[ t ] [ 1.0 1 number= ] unit-test
+
+[ f ] [ 1.0 1 >bignum = ] unit-test
+[ t ] [ 1.0 1 >bignum number= ] unit-test
[ f ] [ 1 1.3 = ] unit-test
[ f ] [ 1 >bignum 1.3 = ] unit-test
[ 2.0 ] [ 1.0 1+ ] unit-test
[ 0.0 ] [ 1.0 1- ] unit-test
-! [ t ] [ -0.0 -0.0 = ] unit-test
-! [ f ] [ 0.0 -0.0 = ] unit-test
-
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
-! [ t ] [ 0.0/0.0 0.0/0.0 = ] unit-test
+! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
[ 0 ] [ 1/0. >bignum ] unit-test
M: float >bignum float>bignum ;
M: float >float ;
+M: float hashcode* nip float>bits ;
+M: float equal? over float? [ float= ] [ 2drop f ] if ;
+M: float number= float= ;
+
M: float < float< ;
M: float <= float<= ;
M: float > float> ;
M: float >= float>= ;
-M: float number= float= ;
M: float + float+ ;
M: float - float- ;
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences
M: fixnum >bignum fixnum>bignum ;
M: fixnum >integer ;
+M: fixnum hashcode* nip ;
+M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
M: fixnum number= eq? ;
M: fixnum < fixnum< ;
M: bignum >fixnum bignum>fixnum ;
M: bignum >bignum ;
+M: bignum hashcode* nip >fixnum ;
+
+M: bignum equal?
+ over bignum? [ bignum= ] [
+ swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
+ ] if ;
+
M: bignum number= bignum= ;
+
M: bignum < bignum< ;
M: bignum <= bignum<= ;
M: bignum > bignum> ;
{ $subsection < }
{ $subsection <= }
{ $subsection > }
-{ $subsection >= } ;
+{ $subsection >= }
+"Numbers can be compared for equality using " { $link = } ", or a less precise test which disregards types:"
+{ $subsection number= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
HELP: number=
{ $values { "x" number } { "y" number } { "?" "a boolean" } }
-{ $description "Tests if two numbers have the same numerical value. If either input is not a number, outputs " { $link f } "." }
-{ $notes "Do not call this word directly. Calling " { $link = } " has the same effect and is more concise." } ;
+{ $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." }
+{ $examples
+ { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" }
+ { $example "USING: math prettyprint ;" "3.0 3 = ." "f" }
+} ;
HELP: <
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
HELP: times
{ $values { "n" integer } { "quot" quotation } }
{ $description "Calls the quotation " { $snippet "n" } " times." }
-{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
+{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." }
+{ $examples
+ { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi\n" }
+} ;
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
HELP: real-part
{ $values { "z" number } { "x" real } }
-{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } ;
+{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." }
+{ $examples { $example "C{ 1 2 } real-part ." "1" } } ;
HELP: imaginary-part
{ $values { "z" number } { "y" real } }
-{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
+{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." }
+{ $examples
+ { $example "C{ 1 2 } imaginary-part ." "2" }
+ { $example "3 imaginary-part ." "0" }
+} ;
HELP: real
{ $class-description "The class of real numbers, which is a disjoint union of rationals and floats." } ;
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
UNION: number real complex ;
-M: number equal? number= ;
-
-M: real hashcode* nip >fixnum ;
-
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
[ t ] [ [ ] all-equal? ] unit-test
[ t ] [ [ 1234 ] all-equal? ] unit-test
-[ t ] [ [ 1.0 1 1 ] all-equal? ] unit-test
+[ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test
[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
[ [ 2 3 4 ] ] [ [ 1 2 3 ] 1 [ + ] curry map ] unit-test
[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } nths ] unit-test
[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } nths ] unit-test
[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } nths ] unit-test
+
+TUPLE: bogus-hashcode ;
+
+M: bogus-hashcode hashcode* 2drop 0 >bignum ;
+
+[ 0 ] [ { T{ bogus-hashcode } } hashcode ] unit-test
[ mismatch not ] [ 2drop f ] if ; inline
: sequence-hashcode-step ( oldhash newpart -- newhash )
- swap [
+ >fixnum swap [
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
- 0 -rot [
- hashcode* >fixnum sequence-hashcode-step
- ] with each ; inline
+ 0 -rot [ hashcode* sequence-hashcode-step ] with each ; inline
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
projects / factor.git / commitdiff