From 55a89ec9c26e6e20bf28c21e8f4bbbef09f8b3f2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Feb 2010 20:50:44 +1300
Subject: [PATCH] Better error message for call( when quotation has the wrong
 effect

---
 .../call-effect/call-effect-tests.factor        |  2 +-
 .../propagation/call-effect/call-effect.factor  | 17 ++++++-----------
 basis/debugger/debugger.factor                  |  2 +-
 core/combinators/combinators.factor             | 15 ++++++++++-----
 4 files changed, 18 insertions(+), 18 deletions(-)

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
index 4b524fd0d4..03bf43418e 100644
--- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
@@ -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 ;
diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index 0feeb211a0..36883e0456 100644
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -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?
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index ba90d761cc..3c2e6b6dc6 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -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 “--”" ;
 
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 55cc55c334..ddaa4eac02 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -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 ;