[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
-[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
+[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f [ call(-redefine-test ] (( a b -- c )) } = ] must-fail-with
! See if redefining a tuple class bumps effect counter
TUPLE: my-tuple a b c ;
over +unknown+ eq?
[ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
-: (call-effect-slow>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip
- '[ _ wrong-values ] , \ unless ,
- ] [ ] make ;
-
: call-effect-slow>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect-slow>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
+ [ \ call-effect def>> curry ] [ add-effect-input ] bi
+ '[ _ _ call-effect-unsafe ] ;
: call-effect-slow ( quot effect -- ) drop call ;
[ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? )
- over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+ over optimized?
+ [ [ stack-effect { effect } declare ] dip effect<= ]
+ [ 2drop f ]
+ if ; inline
: execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe?
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
-! Copyright (C) 2006, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2006, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
PRIVATE>
-ERROR: wrong-values effect ;
+ERROR: wrong-values quot effect ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in
SLOT: out
: call-effect ( quot effect -- )
- [ [ datastack ] dip dip ] dip
- [ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip
- [ wrong-values ] curry unless ;
+ [ datastack ] 2dip
+ [
+ [ dip ] dip
+ [ in>> length ] [ out>> length ] bi
+ check-datastack
+ ]
+ [ [ wrong-values ] 2curry ] 2bi
+ unless ;
: execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ;