Better error message for call( when quotation has the wrong effect

db4
Slava Pestov 2010-02-01 20:50:44 +13:00
parent df55fed478
commit 55a89ec9c2
4 changed files with 18 additions and 18 deletions

View File

@ -78,7 +78,7 @@ TUPLE: a-tuple x ;
[ ] [ "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 ;

View File

@ -81,17 +81,9 @@ M: quotation cached-effect
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 ;
@ -118,7 +110,10 @@ M: quotation cached-effect
[ '[ _ 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?

View File

@ -339,7 +339,7 @@ M: check-mixin-class summary drop "Not a mixin class" ;
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 “--”" ;

View File

@ -1,4 +1,4 @@
! 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
@ -17,16 +17,21 @@ M: object throw
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 ;