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

basis/prettyprint/prettyprint.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs colors combinators grouping io
+USING: arrays accessors assocs colors combinators grouping io
 io.streams.string io.styles kernel make math math.parser namespaces
 parser prettyprint.backend prettyprint.config prettyprint.custom
 prettyprint.sections quotations sequences sorting strings vocabs
@@ -40,12 +40,15 @@ IN: prettyprint
             \ USING: pprint-word
             [ pprint-vocab ] each
             \ ; pprint-word
-        ] with-pprint nl
+        ] with-pprint
     ] unless-empty ;
 
 : use/in. ( in use -- )
-    dupd remove [ { "syntax" "scratchpad" } member? not ] filter
+    over "syntax" 2array diff
-    use. in. ;
+    [ nip use. ]
+    [ empty? not and [ nl ] when ]
+    [ drop in. ]
+    2tri ;
 
 : vocab-names ( words -- vocabs )
     dictionary get
@@ -68,7 +71,8 @@ IN: prettyprint
 PRIVATE>
 
 : with-use ( obj quot -- )
-    make-pprint use/in. nl do-pprint ; inline
+    make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi
+    do-pprint ; inline
 
 : with-in ( obj quot -- )
     make-pprint drop [ write-in bl ] when* do-pprint ; inline

basis/stack-checker/transforms/transforms.factor

@@ -10,10 +10,11 @@ stack-checker.recursive-state ;
 IN: stack-checker.transforms
 
 : give-up-transform ( word -- )
-    dup recursive-word?
+    {
-    [ call-recursive-word ]
+        { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
-    [ dup infer-word apply-word/effect ]
+        { [ dup recursive-word? ] [ call-recursive-word ] }
-    if ;
+        [ dup infer-word apply-word/effect ]
+    } cond ;
 
 :: ((apply-transform)) ( word quot values stack rstate -- )
     rstate recursive-state

basis/ui/gadgets/glass/glass.factor

@@ -63,7 +63,8 @@ TUPLE: popup < wrapper owner ;
         swap >>owner ; inline
 
 M: popup hide-glass-hook
-    owner>> f >>popup request-focus ;
+    dup owner>> 2dup popup>> eq?
+    [ f >>popup request-focus drop ] [ 2drop ] if ;
 
 PRIVATE>
 
@@ -75,7 +76,5 @@ popup H{
     popup>> focusable-child resend-gesture ;
 
 : show-popup ( owner popup visible-rect -- )
-    [ <popup> ] dip
+    [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
-    [ drop dup owner>> (>>popup) ]
+    [ drop >>popup drop ] [ show-glass ] 3bi ;
-    [ [ [ owner>> ] keep ] dip show-glass ]
-    2bi ;

core/classes/predicate/predicate-tests.factor

@@ -1,4 +1,4 @@
-USING: math tools.test classes.algebra ;
+USING: math tools.test classes.algebra words kernel sequences assocs ;
 IN: classes.predicate
 
 PREDICATE: negative < integer 0 < ;
@@ -19,3 +19,9 @@ M: positive abs ;
 [ 10 ] [ -10 abs ] unit-test
 [ 10 ] [ 10 abs ] unit-test
 [ 0 ] [ 0 abs ] unit-test
+
+PREDICATE: blah < word blah eq? ;
+
+[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test
+
+FORGET: blah

core/classes/predicate/predicate.factor

@@ -25,8 +25,9 @@ DEFER: predicate-instance? ( object class -- ? )
 : predicate-quot ( class -- quot )
     [
         \ dup ,
-        dup superclass "predicate" word-prop %
+        [ superclass "predicate" word-prop % ]
-        "predicate-definition" word-prop , [ drop f ] , \ if ,
+        [ "predicate-definition" word-prop , ] bi
+        [ drop f ] , \ if ,
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
@@ -42,9 +43,8 @@ DEFER: predicate-instance? ( object class -- ? )
     update-predicate-instance ;
 
 M: predicate-class reset-class
-    [ call-next-method ]
+    [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
-    [ { "predicate-definition" } reset-props ]
+    update-predicate-instance ;
-    bi ;
 
 M: predicate-class rank-class drop 1 ;
 

core/classes/union/union-tests.factor

@@ -70,10 +70,14 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
 
 [ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
 
+[ t ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
 [ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
 
 [ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
 
+[ f ] [ "foo?" "classes.union.tests" lookup predicate? ] unit-test
+
 GENERIC: test-generic ( x -- y )
 
 TUPLE: a-tuple ;