Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-08-19 04:49:18 -05:00
commit fa415c6d05
10 changed files with 77 additions and 30 deletions

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ]

View File

@ -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 }

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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