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 IN: biassocs.tests
<bihash> "h" set <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 at ] unit-test
[ "a" ] [ "A" "b" get value-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 INSTANCE: biassoc assoc
: >biassoc ( assoc -- biassoc ) : >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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals 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 arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private 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 \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
\ absq [ [ interval-absq ] ?change-interval ] "outputs" set-word-prop
: math-closure ( class -- newclass ) : math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object } { fixnum bignum integer rational float real number object }
[ class<= ] with find nip ; [ class<= ] with find nip ;

View File

@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests
[ float ] [ [ { float real } declare + ] final-math-class ] unit-test [ 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 [ 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 [ 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 } ] [ [ V{ string } ] [
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
] unit-test ] unit-test

View File

@ -119,7 +119,9 @@ M: #declare propagate-before
M: #call propagate-before M: #call propagate-before
dup word>> { dup word>> {
{ [ 2dup foldable-call? ] [ fold-call ] } { [ 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 ] [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
[ compute-constraints ] [ compute-constraints ]

View File

@ -71,7 +71,8 @@ t specialize-method? set-global
SYNTAX: HINTS: SYNTAX: HINTS:
scan-object dup wrapper? [ wrapped>> ] when scan-object dup wrapper? [ wrapped>> ] when
[ changed-definition ] [ changed-definition ]
[ parse-definition { } like "specializer" set-word-prop ] bi ; [ subwords [ changed-definition ] each ]
[ parse-definition { } like "specializer" set-word-prop ] tri ;
! Default specializers ! Default specializers
{ first first2 first3 first4 } { 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 ] [ -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 ! Test that commutative interval ops really are
: random-interval-or-empty ( -- obj ) : random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ; 10 random 0 = [ empty-interval ] [ random-interval ] if ;

View File

@ -94,21 +94,25 @@ MEMO: array-capacity-interval ( -- interval )
: interval>points ( int -- from to ) : interval>points ( int -- from to )
[ from>> ] [ to>> ] bi ; [ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval ) : points>interval ( seq -- interval nan? )
dup [ first fp-nan? ] any? [ first fp-nan? not ] partition
[ drop [-inf,inf] ] [ [
dup first [ [ ] [ endpoint-min ] map-reduce ]
[ [ endpoint-min ] reduce ] [ [ ] [ endpoint-max ] map-reduce ] bi
[ [ endpoint-max ] reduce ] <interval>
2bi <interval> ]
] if ; [ 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 ) : (interval-op) ( p1 p2 quot -- p3 )
[ [ first ] [ first ] [ call ] tri* ] [ [ first ] [ first ] [ call ] tri* ]
[ drop [ second ] both? ] [ drop [ second ] both? ]
3bi 2array ; inline 3bi 2array ; inline
: interval-op ( i1 i2 quot -- i3 ) : interval-op ( i1 i2 quot -- i3 nan? )
{ {
[ [ from>> ] [ from>> ] [ ] tri* (interval-op) ] [ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
[ [ to>> ] [ from>> ] [ ] tri* (interval-op) ] [ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
@ -126,10 +130,10 @@ MEMO: array-capacity-interval ( -- interval )
} cond ; inline } cond ; inline
: interval+ ( i1 i2 -- i3 ) : interval+ ( i1 i2 -- i3 )
[ [ + ] interval-op ] do-empty-interval ; [ [ + ] interval-op nan-ok ] do-empty-interval ;
: interval- ( i1 i2 -- i3 ) : interval- ( i1 i2 -- i3 )
[ [ - ] interval-op ] do-empty-interval ; [ [ - ] interval-op nan-ok ] do-empty-interval ;
: interval-intersect ( i1 i2 -- i3 ) : interval-intersect ( i1 i2 -- i3 )
{ {
@ -154,7 +158,7 @@ MEMO: array-capacity-interval ( -- interval )
{ [ dup empty-interval eq? ] [ drop ] } { [ dup empty-interval eq? ] [ drop ] }
{ [ over full-interval eq? ] [ drop ] } { [ over full-interval eq? ] [ drop ] }
{ [ dup full-interval eq? ] [ nip ] } { [ dup full-interval eq? ] [ nip ] }
[ [ interval>points 2array ] bi@ append points>interval ] [ [ interval>points 2array ] bi@ append points>interval nan-not-ok ]
} cond ; } cond ;
: interval-subset? ( i1 i2 -- ? ) : interval-subset? ( i1 i2 -- ? )
@ -173,7 +177,7 @@ MEMO: array-capacity-interval ( -- interval )
0 swap interval-contains? ; 0 swap interval-contains? ;
: interval* ( i1 i2 -- i3 ) : interval* ( i1 i2 -- i3 )
[ [ [ * ] interval-op ] do-empty-interval ] [ [ [ * ] interval-op nan-ok ] do-empty-interval ]
[ [ interval-zero? ] either? ] [ [ interval-zero? ] either? ]
2bi [ 0 [a,a] interval-union ] when ; 2bi [ 0 [a,a] interval-union ] when ;
@ -220,7 +224,7 @@ MEMO: array-capacity-interval ( -- interval )
[ [
[ [
[ interval-closure ] bi@ [ interval-closure ] bi@
[ shift ] interval-op [ shift ] interval-op nan-not-ok
] interval-integer-op ] interval-integer-op
] do-empty-interval ; ] do-empty-interval ;
@ -235,11 +239,11 @@ MEMO: array-capacity-interval ( -- interval )
: interval-max ( i1 i2 -- i3 ) : interval-max ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! 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 ) : interval-min ( i1 i2 -- i3 )
#! Inaccurate; could be tighter #! 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 ) : interval-interior ( i1 -- i2 )
dup special-interval? [ dup special-interval? [
@ -254,7 +258,7 @@ MEMO: array-capacity-interval ( -- interval )
} cond ; inline } cond ; inline
: interval/ ( i1 i2 -- i3 ) : 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 ) : interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math #! Just a hack to make the compiler work if bootstrap.math
@ -266,13 +270,13 @@ MEMO: array-capacity-interval ( -- interval )
[ [
[ [
[ interval-closure ] bi@ [ interval-closure ] bi@
[ /i ] interval-op [ /i ] interval-op nan-not-ok
] interval-integer-op ] interval-integer-op
] interval-division-op ] interval-division-op
] do-empty-interval ; ] do-empty-interval ;
: interval/f ( i1 i2 -- i3 ) : 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-abs) ( i1 -- i2 )
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ; interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
@ -281,10 +285,13 @@ MEMO: array-capacity-interval ( -- interval )
{ {
{ [ dup empty-interval eq? ] [ ] } { [ dup empty-interval eq? ] [ ] }
{ [ dup full-interval eq? ] [ drop [0,inf] ] } { [ dup full-interval eq? ] [ drop [0,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] }
[ (interval-abs) points>interval ] [ (interval-abs) points>interval nan-not-ok ]
} cond ; } cond ;
: interval-absq ( i1 -- i2 )
interval-abs interval-sq ;
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; : 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 "class-intersect-no-method-c" parse-stream drop
] unit-test ] 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 ; TUPLE: forgotten-predicate-test ;
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test [ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test

View File

@ -122,6 +122,6 @@ DEFER: x
[ [
all-words [ all-words [
"compiled-uses" word-prop "compiled-uses" word-prop
keys [ "forgotten" word-prop ] any? keys [ "forgotten" word-prop ] filter
] filter ] map harvest
] unit-test ] unit-test