Better error message for call( when quotation has the wrong effect
parent
df55fed478
commit
55a89ec9c2
|
@ -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 ;
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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 “--”" ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue