From 68a221c88384fee92f1da83b7ea64ba195bb6237 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 4 Dec 2006 08:29:15 +0000
Subject: [PATCH] Stricter error checking for 'execute' in compiled code

---
 core/compiler/inference/inference.factor   |  6 +++++-
 core/compiler/inference/known-words.factor |  4 +---
 core/compiler/inference/words.factor       | 11 ++++++-----
 core/compiler/test/inference.factor        |  2 ++
 core/compiler/test/simple.factor           | 10 ++++++++++
 5 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/core/compiler/inference/inference.factor b/core/compiler/inference/inference.factor
index adf4f5bbde..6f7c475752 100644
--- a/core/compiler/inference/inference.factor
+++ b/core/compiler/inference/inference.factor
@@ -56,7 +56,7 @@ SYMBOL: recorded
     dataflow-graph off
     current-node off ;
 
-GENERIC: apply-object
+GENERIC: apply-object ( obj -- )
 
 : apply-literal ( obj -- )
     #push dup node,
@@ -67,6 +67,10 @@ M: object apply-object apply-literal ;
 
 M: wrapper apply-object wrapped apply-literal ;
 
+GENERIC: apply-word ( word -- )
+
+M: word apply-object apply-word ;
+
 : terminate ( -- )
     terminated? on #terminate node, ;
 
diff --git a/core/compiler/inference/known-words.factor b/core/compiler/inference/known-words.factor
index bba878d2bb..fcc351da03 100644
--- a/core/compiler/inference/known-words.factor
+++ b/core/compiler/inference/known-words.factor
@@ -38,9 +38,7 @@ sequences strings vectors words prettyprint namespaces ;
 
 \ execute { word } { } <effect> "inferred-effect" set-word-prop
 
-\ execute [
-    pop-literal unit infer-quot-value
-] "infer" set-word-prop
+\ execute [ pop-literal nip apply-word ] "infer" set-word-prop
 
 \ if { object object object } { } <effect> "inferred-effect" set-word-prop
 
diff --git a/core/compiler/inference/words.factor b/core/compiler/inference/words.factor
index 1097dbc5bf..1aee571606 100644
--- a/core/compiler/inference/words.factor
+++ b/core/compiler/inference/words.factor
@@ -144,7 +144,7 @@ M: compound infer-word
     over "inferred-vars" word-prop
     apply-effect/vars ;
 
-: apply-word ( word -- )
+: default-apply-word ( word -- )
     {
         { [ dup "no-effect" word-prop ] [ no-effect ] }
         { [ dup "infer" word-prop ] [ custom-infer ] }
@@ -152,9 +152,9 @@ M: compound infer-word
         { [ t ] [ dup infer-word apply-effect/vars ] }
     } cond ;
 
-M: word apply-object apply-word ;
+M: word apply-word default-apply-word ;
 
-M: symbol apply-object apply-literal ;
+M: symbol apply-word apply-literal ;
 
 TUPLE: recursive-declare-error word ;
 
@@ -170,7 +170,8 @@ TUPLE: recursive-declare-error word ;
     [ declared-infer ] [ inline-closure ] if ;
 
 : apply-compound ( word -- )
-    dup recursing? [ declared-infer ] [ apply-word ] if ;
+    dup recursing?
+    [ declared-infer ] [ default-apply-word ] if ;
 
 : custom-infer-vars ( word -- )
     dup "infer-vars" word-prop dup [
@@ -180,6 +181,6 @@ TUPLE: recursive-declare-error word ;
         2drop
     ] if ;
 
-M: compound apply-object
+M: compound apply-word
     dup custom-infer-vars
     [ apply-inline ] [ apply-compound ] if-inline ;
diff --git a/core/compiler/test/inference.factor b/core/compiler/test/inference.factor
index 02bce58c0a..56ebbfd53d 100644
--- a/core/compiler/test/inference.factor
+++ b/core/compiler/test/inference.factor
@@ -380,3 +380,5 @@ SYMBOL: x
 [ V{ 2 3 } ] [ [ [ [ 2 get 3 throw ] [ 3 get ] if ] with-scope ] infer drop inferred-vars-reads ] unit-test
 
 [ V{ } ] [ [ 5 set 5 get ] infer drop inferred-vars-reads ] unit-test
+
+[ [ 3.1 execute ] infer ] unit-test-fails
diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor
index 8d538bf959..47a60cd5c4 100644
--- a/core/compiler/test/simple.factor
+++ b/core/compiler/test/simple.factor
@@ -45,3 +45,13 @@ full-gc
 
 : foox dup [ foox ] when ; inline
 : bar foox ;
+
+: xyz 3 ;
+
+: execute-test execute ; inline
+: execute-test-2 \ xyz execute-test ;
+
+\ execute-test-2 compile
+
+[ f ] [ \ execute-test compiled? ] unit-test
+[ 3 ] [ execute-test-2 ] unit-test