Get foldable and flushable declarations working on typed words

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

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

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-gensym < word "typed-gensym" word-prop >boolean ;
-PREDICATE: typed-word < word "typed-word" word-prop ;
+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
+M: typed-gensym stack-effect call-next-method unboxed-effect ;
-    call-next-method unboxed-effect ;
+M: typed-gensym parent-word "typed-gensym" word-prop ;
-M: typed-gensym crossref? 
+M: typed-gensym crossref? parent-word crossref? ;
-    "typed-gensym" word-prop crossref? ;
+M: typed-gensym where parent-word where ;
 
 : define-typed-gensym ( word def effect -- gensym )
     [ 2drop <typed-gensym> dup ]

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
+USING: kernel math math.parser math.order namespaces make
-words assocs combinators accessors arrays quotations ;
+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 ;
 

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

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?
+M: method parent-word
-    "method-generic" word-prop flushable? ;
+    "method-generic" word-prop ;
-
-M: method stack-effect
-    "method-generic" word-prop stack-effect ;
 
 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 ;

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,22 +115,30 @@ 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 ;
 
+GENERIC: foldable? ( word -- ? )
+
+M: word foldable?
+    [ "foldable" word-prop ]
+    [ parent-word dup [ foldable? ] when ] bi or ;
+
 : make-foldable ( word -- )
     dup make-flushable t "foldable" set-word-prop ;
 
-: define-inline ( word def effect -- )
-    [ define-declared ] [ 2drop make-inline ] 3bi ;
-
-GENERIC: flushable? ( word -- ? )
-
-M: word flushable? "flushable" word-prop ;
-
 GENERIC: reset-word ( word -- )
 
 M: word reset-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*