diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor index 2ef54441e1..af10eb18e4 100644 --- a/basis/biassocs/biassocs-tests.factor +++ b/basis/biassocs/biassocs-tests.factor @@ -1,4 +1,4 @@ -USING: biassocs assocs namespaces tools.test ; +USING: biassocs assocs namespaces tools.test hashtables kernel ; IN: biassocs.tests "h" set @@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set [ "A" ] [ "a" "b" get at ] unit-test [ "a" ] [ "A" "b" get value-at ] unit-test + +[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test + +[ ] [ "h" get clone "g" set ] unit-test + +[ ] [ 3 4 "g" get set-at ] unit-test + +[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test + +[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 5956589ba5..7daa478f54 100644 --- a/basis/biassocs/biassocs.factor +++ b/basis/biassocs/biassocs.factor @@ -43,4 +43,7 @@ M: biassoc new-assoc INSTANCE: biassoc assoc : >biassoc ( assoc -- biassoc ) - T{ biassoc } assoc-clone-like ; \ No newline at end of file + T{ biassoc } assoc-clone-like ; + +M: biassoc clone + [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 7c684f5b7f..a9b77681fb 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel effects accessors math math.private math.integers.private math.partial-dispatch math.intervals -math.parser math.order layouts words sequences sequences.private +math.parser math.order math.functions layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private definitions strings.private @@ -41,6 +41,8 @@ IN: compiler.tree.propagation.known-words \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop +\ absq [ [ interval-absq ] ?change-interval ] "outputs" set-word-prop + : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 1c9b27dfbc..321941741e 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float real } declare + ] final-math-class ] unit-test -! [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test +[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test -! [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test +[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test @@ -157,6 +157,18 @@ IN: compiler.tree.propagation.tests [ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test +[ t ] [ [ abs ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] 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 + +[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test + +[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test + [ V{ string } ] [ [ dup string? not [ "Oops" throw ] [ ] if ] final-classes ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 5837d59ef9..88c9831a24 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -119,7 +119,9 @@ M: #declare propagate-before M: #call propagate-before dup word>> { { [ 2dup foldable-call? ] [ fold-call ] } - { [ 2dup do-inlining ] [ 2drop ] } + { [ 2dup do-inlining ] [ + [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos + ] } [ [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] [ compute-constraints ] diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 6b7a6ae8ca..08d794090c 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -71,7 +71,8 @@ t specialize-method? set-global SYNTAX: HINTS: scan-object dup wrapper? [ wrapped>> ] when [ changed-definition ] - [ parse-definition { } like "specializer" set-word-prop ] bi ; + [ subwords [ changed-definition ] each ] + [ parse-definition { } like "specializer" set-word-prop ] tri ; ! Default specializers { first first2 first3 first4 } diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 07c3d8fae7..a2bdf6d98f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -348,6 +348,10 @@ comparison-ops [ [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test +[ t ] [ full-interval interval-abs [0,inf] = ] unit-test + +[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test + ! Test that commutative interval ops really are : random-interval-or-empty ( -- obj ) 10 random 0 = [ empty-interval ] [ random-interval ] if ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 8ea28b2235..99997ab8cb 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -94,21 +94,25 @@ MEMO: array-capacity-interval ( -- interval ) : interval>points ( int -- from to ) [ from>> ] [ to>> ] bi ; -: points>interval ( seq -- interval ) - dup [ first fp-nan? ] any? - [ drop [-inf,inf] ] [ - dup first - [ [ endpoint-min ] reduce ] - [ [ endpoint-max ] reduce ] - 2bi - ] if ; +: points>interval ( seq -- interval nan? ) + [ first fp-nan? not ] partition + [ + [ [ ] [ endpoint-min ] map-reduce ] + [ [ ] [ endpoint-max ] map-reduce ] bi + + ] + [ empty? not ] + bi* ; + +: nan-ok ( interval nan? -- interval ) drop ; inline +: nan-not-ok ( interval nan? -- interval ) [ drop full-interval ] when ; inline : (interval-op) ( p1 p2 quot -- p3 ) [ [ first ] [ first ] [ call ] tri* ] [ drop [ second ] both? ] 3bi 2array ; inline -: interval-op ( i1 i2 quot -- i3 ) +: interval-op ( i1 i2 quot -- i3 nan? ) { [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ] [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ] @@ -126,10 +130,10 @@ MEMO: array-capacity-interval ( -- interval ) } cond ; inline : interval+ ( i1 i2 -- i3 ) - [ [ + ] interval-op ] do-empty-interval ; + [ [ + ] interval-op nan-ok ] do-empty-interval ; : interval- ( i1 i2 -- i3 ) - [ [ - ] interval-op ] do-empty-interval ; + [ [ - ] interval-op nan-ok ] do-empty-interval ; : interval-intersect ( i1 i2 -- i3 ) { @@ -154,7 +158,7 @@ MEMO: array-capacity-interval ( -- interval ) { [ dup empty-interval eq? ] [ drop ] } { [ over full-interval eq? ] [ drop ] } { [ dup full-interval eq? ] [ nip ] } - [ [ interval>points 2array ] bi@ append points>interval ] + [ [ interval>points 2array ] bi@ append points>interval nan-not-ok ] } cond ; : interval-subset? ( i1 i2 -- ? ) @@ -173,7 +177,7 @@ MEMO: array-capacity-interval ( -- interval ) 0 swap interval-contains? ; : interval* ( i1 i2 -- i3 ) - [ [ [ * ] interval-op ] do-empty-interval ] + [ [ [ * ] interval-op nan-ok ] do-empty-interval ] [ [ interval-zero? ] either? ] 2bi [ 0 [a,a] interval-union ] when ; @@ -220,7 +224,7 @@ MEMO: array-capacity-interval ( -- interval ) [ [ [ interval-closure ] bi@ - [ shift ] interval-op + [ shift ] interval-op nan-not-ok ] interval-integer-op ] do-empty-interval ; @@ -235,11 +239,11 @@ MEMO: array-capacity-interval ( -- interval ) : interval-max ( i1 i2 -- i3 ) #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ; + [ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ; : interval-min ( i1 i2 -- i3 ) #! Inaccurate; could be tighter - [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ; + [ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ; : interval-interior ( i1 -- i2 ) dup special-interval? [ @@ -254,7 +258,7 @@ MEMO: array-capacity-interval ( -- interval ) } cond ; inline : interval/ ( i1 i2 -- i3 ) - [ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ; + [ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ; : interval/-safe ( i1 i2 -- i3 ) #! Just a hack to make the compiler work if bootstrap.math @@ -266,13 +270,13 @@ MEMO: array-capacity-interval ( -- interval ) [ [ [ interval-closure ] bi@ - [ /i ] interval-op + [ /i ] interval-op nan-not-ok ] interval-integer-op ] interval-division-op ] do-empty-interval ; : interval/f ( i1 i2 -- i3 ) - [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ; + [ [ [ /f ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ; : (interval-abs) ( i1 -- i2 ) interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ; @@ -281,10 +285,13 @@ MEMO: array-capacity-interval ( -- interval ) { { [ dup empty-interval eq? ] [ ] } { [ dup full-interval eq? ] [ drop [0,inf] ] } - { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } - [ (interval-abs) points>interval ] + { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] } + [ (interval-abs) points>interval nan-not-ok ] } cond ; +: interval-absq ( i1 -- i2 ) + interval-abs interval-sq ; + : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d7fba97977..1c1db09cf4 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -110,6 +110,12 @@ USE: multiline "class-intersect-no-method-c" parse-stream drop ] unit-test +! Forget the above crap +[ + { "classes.test.a" "classes.test.b" "classes.test.c" "classes.test.d" } + [ forget-vocab ] each +] with-compilation-unit + TUPLE: forgotten-predicate-test ; [ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 0ecf7b65f0..c3dacbaf14 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -122,6 +122,6 @@ DEFER: x [ all-words [ "compiled-uses" word-prop - keys [ "forgotten" word-prop ] any? - ] filter + keys [ "forgotten" word-prop ] filter + ] map harvest ] unit-test