Merge branch 'master' of git://factorcode.org/git/factor
commit
fa415c6d05
|
@ -1,4 +1,4 @@
|
|||
USING: biassocs assocs namespaces tools.test ;
|
||||
USING: biassocs assocs namespaces tools.test hashtables kernel ;
|
||||
IN: biassocs.tests
|
||||
|
||||
<bihash> "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
|
||||
|
|
|
@ -43,4 +43,7 @@ M: biassoc new-assoc
|
|||
INSTANCE: biassoc assoc
|
||||
|
||||
: >biassoc ( assoc -- biassoc )
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
|
||||
M: biassoc clone
|
||||
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 <interval>
|
||||
] if ;
|
||||
: points>interval ( seq -- interval nan? )
|
||||
[ first fp-nan? not ] partition
|
||||
[
|
||||
[ [ ] [ endpoint-min ] map-reduce ]
|
||||
[ [ ] [ endpoint-max ] map-reduce ] bi
|
||||
<interval>
|
||||
]
|
||||
[ 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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue