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

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

basis/biassocs/biassocs.factor

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

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 ;

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

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 ]

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 }

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 ;

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

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

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