From 4c51d8524d74902d1ffa27e98d57008c7412871c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 02:58:09 -0500
Subject: [PATCH 1/4] Fix prettyprinting of method definitions and classes
---
basis/prettyprint/prettyprint.factor | 14 +++++++++-----
1 file changed, 9 insertions(+), 5 deletions(-)
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 5eb04c9510..2286417dd1 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/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
- use. in. ;
+ over "syntax" 2array diff
+ [ 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
From a23a6a28707dd8a23402f37fd714273b16f369bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:22:16 -0500
Subject: [PATCH 2/4] Forgetting a predicate class now updates
predicate-instance? word
---
core/classes/predicate/predicate-tests.factor | 8 +++++++-
core/classes/predicate/predicate.factor | 10 +++++-----
core/classes/union/union-tests.factor | 4 ++++
3 files changed, 16 insertions(+), 6 deletions(-)
diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index 3de073f774..d4c929a69b 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/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
\ No newline at end of file
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 4ba93acae4..7d757772f4 100644
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -25,8 +25,9 @@ DEFER: predicate-instance? ( object class -- ? )
: predicate-quot ( class -- quot )
[
\ dup ,
- dup superclass "predicate" word-prop %
- "predicate-definition" word-prop , [ drop f ] , \ if ,
+ [ superclass "predicate" word-prop % ]
+ [ "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 ]
- [ { "predicate-definition" } reset-props ]
- bi ;
+ [ call-next-method ] [ { "predicate-definition" } reset-props ] bi
+ update-predicate-instance ;
M: predicate-class rank-class drop 1 ;
diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor
index 0802c0a2d9..57b742595f 100644
--- a/core/classes/union/union-tests.factor
+++ b/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 ;
From 06f29ab7e459f9f4b335802bbc70239dc8f899ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:28:24 -0500
Subject: [PATCH 3/4] give-up-transform now uses a cached stack effect. Slight
performance improvement when compiling calls to member? with a non-literal
quotation
---
basis/stack-checker/transforms/transforms.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 791e0e65c1..ecc2365cf9 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/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 infer-word apply-word/effect ]
- if ;
+ {
+ { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
+ { [ dup recursive-word? ] [ call-recursive-word ] }
+ [ dup infer-word apply-word/effect ]
+ } cond ;
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
From da254e4621e1e31e165d0b10f091dae296e7b96a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 13 Mar 2009 04:47:56 -0500
Subject: [PATCH 4/4] Opening a second popup if one is already visible hides
the first
---
basis/ui/gadgets/glass/glass.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/basis/ui/gadgets/glass/glass.factor b/basis/ui/gadgets/glass/glass.factor
index af169235b4..945e16150d 100644
--- a/basis/ui/gadgets/glass/glass.factor
+++ b/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
- [ drop dup owner>> (>>popup) ]
- [ [ [ owner>> ] keep ] dip show-glass ]
- 2bi ;
\ No newline at end of file
+ [ [ dup dup popup>> [ hide-glass ] when* ] dip <popup> ] dip
+ [ drop >>popup drop ] [ show-glass ] 3bi ;
\ No newline at end of file