Get foldable and flushable declarations working on typed words

diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index ed417ef9d76102668d1c60b1294698dfbfd98693..ce169233c1a68c93137691b020a55b16e1ff14b5 100644 (file)
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -72,7 +72,7 @@ M: #declare propagate-before
 
 : foldable-call? ( #call word -- ? )
     {
-        [ nip "foldable" word-prop ]
+        [ nip foldable? ]
         [ drop literal-inputs? ]
         [ input-classes-match? ]
     } 2&& ;

diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor
index 7f984ccaf25d49fd6a823764ab4e60f995d6b87b..28ec2b6e86debc5386c59b449bee1dc232bae7ba 100644 (file)
--- a/basis/typed/typed-tests.factor
+++ b/basis/typed/typed-tests.factor
@@ -1,5 +1,6 @@
 USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words ;
+quotations tools.test typed words words.symbol
+compiler.tree.debugger prettyprint ;
 IN: typed.tests
 
 TYPED: f+ ( a: float b: float -- c: float )
@@ -122,3 +123,29 @@ TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
 [ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
 
 [ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+! Make sure that foldable and flushable work on typed words
+TYPED: add ( a: integer b: integer -- c: integer ) + ; foldable
+
+[ [ 3 ] ] [ [ 1 2 add ] cleaned-up-tree nodes>quot ] unit-test
+
+TYPED: flush-test ( s: symbol -- ? ) on t ; flushable
+
+: flush-print-1 ( symbol -- ) flush-test drop ;
+: flush-print-2 ( symbol -- ) flush-test . ;
+
+SYMBOL: a-symbol
+
+[ f ] [
+    f a-symbol [
+        a-symbol flush-print-1
+        a-symbol get
+    ] with-variable
+] unit-test
+
+[ t ] [
+    f a-symbol [
+        a-symbol flush-print-2
+        a-symbol get
+    ] with-variable
+] unit-test

diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor
index e104c69da9704a3209412cbb5581e041f6b1634f..6ab4e0334de98af8508bea547f95ff05378f9af1 100644 (file)
--- a/basis/typed/typed.factor
+++ b/basis/typed/typed.factor
@@ -11,8 +11,8 @@ ERROR: type-mismatch-error word expected-types ;
 ERROR: input-mismatch-error < type-mismatch-error ;
 ERROR: output-mismatch-error < type-mismatch-error ;
 
-PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
-PREDICATE: typed-word < word "typed-word" word-prop ;
+PREDICATE: typed-gensym < word "typed-gensym" word-prop >boolean ;
+PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 
 <PRIVATE
 
@@ -120,10 +120,10 @@ MACRO: (typed) ( word def effect -- quot )
     [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
     [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
 
-M: typed-gensym stack-effect
-    call-next-method unboxed-effect ;
-M: typed-gensym crossref? 
-    "typed-gensym" word-prop crossref? ;
+M: typed-gensym stack-effect call-next-method unboxed-effect ;
+M: typed-gensym parent-word "typed-gensym" word-prop ;
+M: typed-gensym crossref? parent-word crossref? ;
+M: typed-gensym where parent-word where ;
 
 : define-typed-gensym ( word def effect -- gensym )
     [ 2drop <typed-gensym> dup ]

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 1790399e04d2c47a964f98c52a8c608a98be2c99..fea50d298146bdd977a27643669487c7739af8bf 100644 (file)
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.order namespaces make sequences strings
-words assocs combinators accessors arrays quotations ;
+USING: kernel math math.parser math.order namespaces make
+sequences strings words assocs combinators accessors arrays
+quotations ;
 IN: effects
 
 TUPLE: effect
@@ -64,7 +65,9 @@ M: pair effect>type second effect>type ;
 
 GENERIC: stack-effect ( word -- effect/f )
 
-M: word stack-effect "declared-effect" word-prop ;
+M: word stack-effect
+    [ "declared-effect" word-prop ]
+    [ parent-word dup [ stack-effect ] when ] bi or ;
 
 M: deferred stack-effect call-next-method (( -- * )) or ;
 

diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index 700448805c0022f505f9c11ee6edc358c464c6f8..805c3a4be42b7b9d6553eeb5d6c6c8b7a5bf1d59 100644 (file)
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -212,3 +212,16 @@ M: integer forget-test 3 + ;
 ] unit-test
 
 [ 10 forget-test ] [ no-method? ] must-fail-with
+
+! Declarations on methods
+GENERIC: flushable-generic ( a -- b ) flushable
+M: integer flushable-generic ;
+
+[ t ] [ \ flushable-generic flushable? ] unit-test
+[ t ] [ M\ integer flushable-generic flushable? ] unit-test
+
+GENERIC: non-flushable-generic ( a -- b )
+M: integer non-flushable-generic ; flushable
+
+[ f ] [ \ non-flushable-generic flushable? ] unit-test
+[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test

diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 9fd7a5be853e0ba9fc06d05319681327b08d9912..0c626ac1d6105d1a8d305cb3fa8684fb6f103263 100644 (file)
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
@@ -104,11 +104,8 @@ GENERIC: update-generic ( class generic -- )
 : method-word-name ( class generic -- string )
     [ name>> ] bi@ "=>" glue ;
 
-M: method flushable?
-    "method-generic" word-prop flushable? ;
-
-M: method stack-effect
-    "method-generic" word-prop stack-effect ;
+M: method parent-word
+    "method-generic" word-prop ;
 
 M: method crossref?
     "forgotten" word-prop not ;
@@ -196,8 +193,5 @@ M: generic subwords
         tri
     ] { } make ;
 
-M: generic forget*
-    [ subwords forget-all ] [ call-next-method ] bi ;
-
 M: class forget-methods
     [ implementors ] [ [ swap method ] curry ] bi map forget-all ;

diff --git a/core/words/words.factor b/core/words/words.factor
index 5b057230fe8e8daaa87f1a537c4a3e12807e3b88..2a4c2c4c06a130121f0c33b1db8bfb5cf70d52d7 100644 (file)
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -73,12 +73,14 @@ GENERIC: crossref? ( word -- ? )
 M: word crossref?
     dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
 
-: inline? ( word -- ? ) "inline" word-prop ; inline
-
 GENERIC: subwords ( word -- seq )
 
 M: word subwords drop f ;
 
+GENERIC: parent-word ( word -- word/f )
+
+M: word parent-word drop f ;
+
 : define ( word def -- )
     over changed-definition [ ] like >>def drop ;
 
@@ -100,6 +102,8 @@ M: word subwords drop f ;
 : make-deprecated ( word -- )
     t "deprecated" set-word-prop ;
 
+: inline? ( word -- ? ) "inline" word-prop ; inline
+
 ERROR: cannot-be-inline word ;
 
 GENERIC: make-inline ( word -- )
@@ -111,21 +115,29 @@ M: word make-inline
         bi
     ] if ;
 
+: define-inline ( word def effect -- )
+    [ define-declared ] [ 2drop make-inline ] 3bi ;
+
 : make-recursive ( word -- )
     t "recursive" set-word-prop ;
 
+GENERIC: flushable? ( word -- ? )
+
+M: word flushable?
+    [ "flushable" word-prop ]
+    [ parent-word dup [ flushable? ] when ] bi or ;
+
 : make-flushable ( word -- )
     t "flushable" set-word-prop ;
 
-: make-foldable ( word -- )
-    dup make-flushable t "foldable" set-word-prop ;
-
-: define-inline ( word def effect -- )
-    [ define-declared ] [ 2drop make-inline ] 3bi ;
+GENERIC: foldable? ( word -- ? )
 
-GENERIC: flushable? ( word -- ? )
+M: word foldable?
+    [ "foldable" word-prop ]
+    [ parent-word dup [ foldable? ] when ] bi or ;
 
-M: word flushable? "flushable" word-prop ;
+: make-foldable ( word -- )
+    dup make-flushable t "foldable" set-word-prop ;
 
 GENERIC: reset-word ( word -- )
 
@@ -208,9 +220,10 @@ M: word set-where swap "loc" set-word-prop ;
 
 M: word forget*
     dup "forgotten" word-prop [ drop ] [
+        [ subwords forget-all ]
         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
         [ t "forgotten" set-word-prop ]
-        bi
+        tri
     ] if ;
 
 M: word hashcode*