steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
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 [ ] [ "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 ! See if redefining a tuple class bumps effect counter
TUPLE: my-tuple a b c ; TUPLE: my-tuple a b c ;

17
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -81,17 +81,9 @@ M: quotation cached-effect
over +unknown+ eq? over +unknown+ eq?
[ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline [ 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 ) : call-effect-slow>quot ( effect -- quot )
[ in>> length ] [ out>> length ] [ ] tri [ \ call-effect def>> curry ] [ add-effect-input ] bi
[ (call-effect-slow>quot) ] keep add-effect-input '[ _ _ call-effect-unsafe ] ;
[ call-effect-unsafe ] 2curry ;
: call-effect-slow ( quot effect -- ) drop call ; : call-effect-slow ( quot effect -- ) drop call ;
@ -118,7 +110,10 @@ M: quotation cached-effect
[ '[ _ execute ] ] dip call-effect-slow ; inline [ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? ) : 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 -- ) : execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe? 2over execute-effect-unsafe?

2
basis/debugger/debugger.factor
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: 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 “--”" ; M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;

15
core/combinators/combinators.factor
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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors kernel kernel.private math assocs quotations vectors
@ -17,16 +17,21 @@ M: object throw
PRIVATE> PRIVATE>
ERROR: wrong-values effect ; ERROR: wrong-values quot effect ;
! We can't USE: effects here so we forward reference slots instead ! We can't USE: effects here so we forward reference slots instead
SLOT: in SLOT: in
SLOT: out SLOT: out
: call-effect ( quot effect -- ) : call-effect ( quot effect -- )
[ [ datastack ] dip dip ] dip [ datastack ] 2dip
[ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip [
[ wrong-values ] curry unless ; [ dip ] dip
[ in>> length ] [ out>> length ] bi
check-datastack
]
[ [ wrong-values ] 2curry ] 2bi
unless ;
: execute-effect ( word effect -- ) : execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ; [ [ execute ] curry ] dip call-effect ;