diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index ed417ef9d7..ce169233c1 100644 --- 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 7f984ccaf2..28ec2b6e86 100644 --- 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 e104c69da9..6ab4e0334d 100644 --- 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 ; ; -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 dup ] diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 1790399e04..fea50d2981 100644 --- 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 700448805c..805c3a4be4 100644 --- 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 9fd7a5be85..0c626ac1d6 100644 --- 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 5b057230fe..2a4c2c4c06 100644 --- 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,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*